Merge branch 'master' into staging

10 files changed, 136 insertions, 41 deletions

diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm
index af04084c86..f794bf006b 100644
--- a/guix/build-system/asdf.scm
+++ b/guix/build-system/asdf.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca>
+;;; Copyright © 2019 Guillaume Le Vaillant <glv@posteo.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -32,6 +33,7 @@
   #:use-module (ice-9 regex)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
+  #:use-module (gnu packages)
   #:export (%asdf-build-system-modules
             %asdf-build-modules
             asdf-build
@@ -160,13 +162,22 @@ set up using CL source package conventions."
   (define (has-from-build-system? pkg)
     (eq? from-build-system (package-build-system pkg)))
 
+  (define (find-input-package pkg)
+    (let* ((name (package-name pkg))
+           (new-name (transform-package-name name))
+           (pkgs (find-packages-by-name new-name)))
+      (if (null? pkgs) #f (list-ref pkgs 0))))
+
   (define transform
     (mlambda (pkg)
       (define rewrite
         (match-lambda
           ((name content . rest)
            (let* ((is-package? (package? content))
-                  (new-content (if is-package? (transform content) content)))
+                  (new-content (if is-package?
+                                   (or (find-input-package content)
+                                       (transform content))
+                                   content)))
              `(,name ,new-content ,@rest)))))
 
       ;; Special considerations for source packages: CL inputs become
diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm
index c9140074b7..3cc89f8852 100644
--- a/guix/build-system/gnu.scm
+++ b/guix/build-system/gnu.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, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -57,12 +57,16 @@
   '((guix build gnu-build-system)
     (guix build utils)))
 
-(define* (package-with-explicit-inputs p inputs
-                                       #:optional
-                                       (loc (current-source-location))
-                                       #:key (native-inputs '())
-                                       guile)
-  "Rewrite P, which is assumed to use GNU-BUILD-SYSTEM, to take INPUTS and
+(define* (package-with-explicit-inputs/deprecated p inputs
+                                                  #:optional
+                                                  (loc (current-source-location))
+                                                  #:key (native-inputs '())
+                                                  guile)
+  "This variant is deprecated because it is inefficient: it memoizes only
+temporarily instead of memoizing across all transformations where INPUTS is
+the same.
+
+Rewrite P, which is assumed to use GNU-BUILD-SYSTEM, to take INPUTS and
 NATIVE-INPUTS as explicit inputs instead of the implicit default, and return
 it.  INPUTS and NATIVE-INPUTS can be either input lists or thunks; in the
 latter case, they will be called in a context where the `%current-system' and
@@ -124,6 +128,47 @@ builder, or the distro's final Guile when GUILE is #f."
            ,@(map rewritten-input
                   (filtered (package-inputs p)))))))))
 
+(define* (package-with-explicit-inputs* inputs #:optional guile)
+  "Return a procedure that rewrites the given package and all its dependencies
+so that they use INPUTS (a thunk) instead of implicit inputs."
+  (define (duplicate-filter package-inputs)
+    (let ((names (match (inputs)
+                   (((name _ ...) ...)
+                    name))))
+      (fold alist-delete package-inputs names)))
+
+  (define (add-explicit-inputs p)
+    (if (and (eq? (package-build-system p) gnu-build-system)
+             (not (memq #:implicit-inputs? (package-arguments p))))
+        (package
+          (inherit p)
+          (inputs (append (inputs)
+                          (duplicate-filter (package-inputs p))))
+          (arguments
+           (ensure-keyword-arguments (package-arguments p)
+                                     `(#:implicit-inputs? #f
+                                       #:guile ,guile))))
+        p))
+
+  (define (cut? p)
+    (and (eq? (package-build-system p) gnu-build-system)
+         (memq #:implicit-inputs? (package-arguments p))))
+
+  (package-mapping add-explicit-inputs cut?))
+
+(define package-with-explicit-inputs
+  (case-lambda*
+   ((inputs #:optional guile)
+    (package-with-explicit-inputs* inputs guile))
+   ((p inputs #:optional (loc (current-source-location))
+       #:key (native-inputs '()) guile)
+    ;; deprecated
+    (package-with-explicit-inputs/deprecated p inputs
+                                             loc
+                                             #:native-inputs
+                                             native-inputs
+                                             #:guile guile))))
+
 (define (package-with-extra-configure-variable p variable value)
   "Return a version of P with VARIABLE=VALUE specified as an extra `configure'
 flag, recursively.  An example is LDFLAGS=-static.  If P already has configure
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 600750e846..7323277511 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -1508,7 +1508,7 @@ are searched for in PATH.  Return #f when MODULES and EXTENSIONS are empty."
          (gexp (eval-when (expand load eval)
                  ;; Augment the load paths and delete duplicates.  Do that
                  ;; without loading (srfi srfi-1) or anything.
-                 (let ((extensions '((ungexp-native-splicing extensions)))
+                 (let ((extensions '((ungexp-splicing extensions)))
                        (prepend (lambda (items lst)
                                   ;; This is O(N²) but N is typically small.
                                   (let loop ((items items)
diff --git a/guix/inferior.scm b/guix/inferior.scm
index d6d2053ab8..b8e2f21f42 100644
--- a/guix/inferior.scm
+++ b/guix/inferior.scm
@@ -110,11 +110,11 @@
   (packages inferior-package-promise)            ;promise of inferior packages
   (table    inferior-package-table))             ;promise of vhash
 
-(define (inferior-pipe directory command)
+(define* (inferior-pipe directory command error-port)
   "Return an input/output pipe on the Guix instance in DIRECTORY.  This runs
 'DIRECTORY/COMMAND repl' if it exists, or falls back to some other method if
 it's an old Guix."
-  (let ((pipe (with-error-to-port (%make-void-port "w")
+  (let ((pipe (with-error-to-port error-port
                 (lambda ()
                   (open-pipe* OPEN_BOTH
                               (string-append directory "/" command)
@@ -125,19 +125,21 @@ it's an old Guix."
 
           ;; Older versions of Guix didn't have a 'guix repl' command, so
           ;; emulate it.
-          (open-pipe* OPEN_BOTH "guile"
-                      "-L" (string-append directory "/share/guile/site/"
-                                          (effective-version))
-                      "-C" (string-append directory "/share/guile/site/"
-                                          (effective-version))
-                      "-C" (string-append directory "/lib/guile/"
-                                          (effective-version) "/site-ccache")
-                      "-c"
-                      (object->string
-                       `(begin
-                          (primitive-load ,(search-path %load-path
-                                                        "guix/repl.scm"))
-                          ((@ (guix repl) machine-repl))))))
+          (with-error-to-port error-port
+            (lambda ()
+              (open-pipe* OPEN_BOTH "guile"
+                          "-L" (string-append directory "/share/guile/site/"
+                                              (effective-version))
+                          "-C" (string-append directory "/share/guile/site/"
+                                              (effective-version))
+                          "-C" (string-append directory "/lib/guile/"
+                                              (effective-version) "/site-ccache")
+                          "-c"
+                          (object->string
+                           `(begin
+                              (primitive-load ,(search-path %load-path
+                                                            "guix/repl.scm"))
+                              ((@ (guix repl) machine-repl))))))))
         pipe)))
 
 (define* (port->inferior pipe #:optional (close close-port))
@@ -161,11 +163,13 @@ inferior."
     (_
      #f)))
 
-(define* (open-inferior directory #:key (command "bin/guix"))
+(define* (open-inferior directory
+                        #:key (command "bin/guix")
+                        (error-port (%make-void-port "w")))
   "Open the inferior Guix in DIRECTORY, running 'DIRECTORY/COMMAND repl' or
 equivalent.  Return #f if the inferior could not be launched."
   (define pipe
-    (inferior-pipe directory command))
+    (inferior-pipe directory command error-port))
 
   (port->inferior pipe close-pipe))
 
diff --git a/guix/lint.scm b/guix/lint.scm
index 03a8e88225..6336cf4e3b 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -1319,11 +1319,17 @@ or a list thereof")
      (name        'github-url)
      (description "Suggest GitHub URLs")
      (check       check-github-url))
-   (lint-checker
-     (name        'cve)
-     (description "Check the Common Vulnerabilities and Exposures\
- (CVE) database")
-     (check       check-vulnerabilities))
+
+   ;; FIXME: Commented out as a consequence of the XML CVE feed retirement:
+   ;; <https://nvd.nist.gov/General/News/XML-Vulnerability-Feed-Retirement-Phase-3>.
+   ;; Reinstate it once the JSON feed is supported.
+
+ ;;   (lint-checker
+ ;;     (name        'cve)
+ ;;     (description "Check the Common Vulnerabilities and Exposures\
+ ;; (CVE) database")
+ ;;     (check       check-vulnerabilities))
+
    (lint-checker
      (name        'refresh)
      (description "Check the package for new upstream releases")
diff --git a/guix/profiles.scm b/guix/profiles.scm
index f5c863945c..cd3b21e390 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -1732,7 +1732,8 @@ because the NUMBER is zero.)"
   (string-append %profile-directory "/guix-profile"))
 
 (define (ensure-profile-directory)
-  "Attempt to create /…/profiles/per-user/$USER if needed."
+  "Attempt to create /…/profiles/per-user/$USER if needed.  Nowadays this is
+taken care of by the daemon."
   (let ((s (stat %profile-directory #f)))
     (unless (and s (eq? 'directory (stat:type s)))
       (catch 'system-error
diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index bb307cefd1..1384f6b41d 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -174,7 +174,7 @@ can interpret meaningfully."
 private key from '~a': ~a")
                                          file str))))))))
 
-(define (open-ssh-session machine)
+(define* (open-ssh-session machine #:optional (max-silent-time -1))
   "Open an SSH session for MACHINE and return it.  Throw an error on failure."
   (let ((private (private-key-from-file* (build-machine-private-key machine)))
         (public  (public-key-from-file
@@ -183,7 +183,7 @@ private key from '~a': ~a")
         (session (make-session #:user (build-machine-user machine)
                                #:host (build-machine-name machine)
                                #:port (build-machine-port machine)
-                               #:timeout 10       ;seconds
+                               #:timeout 10       ;initial timeout (seconds)
                                ;; #:log-verbosity 'protocol
                                #:identity (build-machine-private-key machine)
 
@@ -225,6 +225,10 @@ instead of '~a' of type '~a'~%")
            (leave (G_ "SSH public key authentication failed for '~a': ~a~%")
                   (build-machine-name machine) (get-error session))))
 
+       ;; From then on use MAX-SILENT-TIME as the absolute timeout when
+       ;; reading from or write to a channel for this session.
+       (session-set! session 'timeout max-silent-time)
+
        session)
       (x
        ;; Connection failed or timeout expired.
@@ -313,7 +317,7 @@ hook."
 INPUTS to MACHINE; if building DRV succeeds, retrieve all of OUTPUTS from
 MACHINE."
   (define session
-    (open-ssh-session machine))
+    (open-ssh-session machine max-silent-time))
 
   (define store
     (connect-to-remote-daemon session
@@ -472,7 +476,8 @@ slot (which must later be released with 'release-build-slot'), or #f and #f."
        ;; Return the best machine unless it's already overloaded.
        ;; Note: We call 'node-load' only as a last resort because it is
        ;; too costly to call it once for every machine.
-       (let* ((session (false-if-exception (open-ssh-session best)))
+       (let* ((session (false-if-exception (open-ssh-session best
+                                                             %short-timeout)))
               (node    (and session (remote-inferior session)))
               (load    (and node (normalized-load best (node-load node))))
               (space   (and node (node-free-disk-space node))))
@@ -573,6 +578,11 @@ If TIMEOUT is #f, simply evaluate EXP..."
 ;;; Installation tests.
 ;;;
 
+(define %short-timeout
+  ;; Timeout in seconds used on SSH connections where reads and writes
+  ;; shouldn't take long.
+  15)
+
 (define (assert-node-repl node name)
   "Bail out if NODE is not running Guile."
   (match (node-guile-version node)
@@ -658,7 +668,7 @@ machine."
           (length machines) machine-file)
     (let* ((names    (map build-machine-name machines))
            (sockets  (map build-machine-daemon-socket machines))
-           (sessions (map open-ssh-session machines))
+           (sessions (map (cut open-ssh-session <> %short-timeout) machines))
            (nodes    (map remote-inferior sessions)))
       (for-each assert-node-has-guix nodes names)
       (for-each assert-node-repl nodes names)
@@ -682,7 +692,7 @@ machine."
           (length machines) machine-file)
     (for-each (lambda (machine)
                 (define session
-                  (open-ssh-session machine))
+                  (open-ssh-session machine %short-timeout))
 
                 (match (remote-inferior session)
                   (#f
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 04970cf503..7876019eac 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -772,11 +772,11 @@ Use '~/.config/guix/channels.scm' instead."))
               (process-generation-change opts profile))
              (else
               (with-store store
-                (ensure-default-profile)
                 (with-status-verbosity (assoc-ref opts 'verbosity)
                   (parameterize ((%current-system (assoc-ref opts 'system))
                                  (%graft? (assoc-ref opts 'graft?)))
                     (set-build-options-from-command-line store opts)
+                    (ensure-default-profile)
                     (honor-x509-certificates store)
 
                     (let ((instances (latest-channel-instances store channels)))
diff --git a/guix/ssh.scm b/guix/ssh.scm
index b6b55bdfcb..5fd3c280e8 100644
--- a/guix/ssh.scm
+++ b/guix/ssh.scm
@@ -61,11 +61,16 @@
   "zlib@openssh.com,zlib")
 
 (define* (open-ssh-session host #:key user port identity
-                           (compression %compression))
+                           (compression %compression)
+                           (timeout 3600))
   "Open an SSH session for HOST and return it.  IDENTITY specifies the file
 name of a private key to use for authenticating with the host.  When USER,
 PORT, or IDENTITY are #f, use default values or whatever '~/.ssh/config'
-specifies; otherwise use them.  Throw an error on failure."
+specifies; otherwise use them.  Install TIMEOUT as the maximum time in seconds
+after which a read or write operation on a channel of the returned session is
+considered as failing.
+
+Throw an error on failure."
   (let ((session (make-session #:user user
                                #:identity identity
                                #:host host
@@ -86,6 +91,7 @@ specifies; otherwise use them.  Throw an error on failure."
        ;; Use public key authentication, via the SSH agent if it's available.
        (match (userauth-public-key/auto! session)
          ('success
+          (session-set! session 'timeout timeout)
           session)
          (x
           (disconnect! session)
diff --git a/guix/store.scm b/guix/store.scm
index d7c603898c..382aad29d9 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -748,6 +748,14 @@ encoding conversion errors."
            (cut string-append "http://" <>))
        '("ci.guix.gnu.org")))
 
+(define (current-user-name)
+  "Return the name of the calling user."
+  (catch #t
+    (lambda ()
+      (passwd:name (getpwuid (getuid))))
+    (lambda _
+      (getenv "USER"))))
+
 (define* (set-build-options server
                             #:key keep-failed? keep-going? fallback?
                             (verbosity 0)
@@ -759,6 +767,7 @@ encoding conversion errors."
                             (build-verbosity 0)
                             (log-type 0)
                             (print-build-trace #t)
+                            (user-name (current-user-name))
 
                             ;; When true, provide machine-readable "build
                             ;; traces" for use by (guix status).  Old clients
@@ -849,6 +858,9 @@ encoding conversion errors."
                            `(("build-repeat"
                               . ,(number->string (max 0 (1- rounds)))))
                            '())
+                     ,@(if user-name
+                           `(("user-name" . ,user-name))
+                           '())
                      ,@(if terminal-columns
                            `(("terminal-columns"
                               . ,(number->string terminal-columns)))