Merge branch 'master' into staging

9 files changed, 204 insertions, 115 deletions

diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index d69b178a0a..85c1c45f81 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -1218,7 +1218,7 @@ handler if the lock is already held by another process."
   ;; zero.
   16)
 
-(define (set-thread-name name)
+(define (set-thread-name!/linux name)
   "Set the name of the calling thread to NAME.  NAME is truncated to 15
 bytes."
   (let ((ptr (string->pointer name)))
@@ -1231,7 +1231,7 @@ bytes."
                (list (strerror err))
                (list err))))))
 
-(define (thread-name)
+(define (thread-name/linux)
   "Return the name of the calling thread as a string."
   (let ((buf (make-bytevector %max-thread-name-length)))
     (let-values (((ret err)
@@ -1245,6 +1245,16 @@ bytes."
                  (list (strerror err))
                  (list err))))))
 
+(define set-thread-name
+  (if (string-contains %host-type "linux")
+      set-thread-name!/linux
+      (const #f)))
+
+(define thread-name
+  (if (string-contains %host-type "linux")
+      thread-name/linux
+      (const "")))
+
 
 ;;;
 ;;; Network interfaces.
diff --git a/guix/git-authenticate.scm b/guix/git-authenticate.scm
index b73f957105..00d22ef479 100644
--- a/guix/git-authenticate.scm
+++ b/guix/git-authenticate.scm
@@ -19,6 +19,7 @@
 (define-module (guix git-authenticate)
   #:use-module (git)
   #:use-module (guix base16)
+  #:use-module ((guix git) #:select (false-if-git-not-found))
   #:use-module (guix i18n)
   #:use-module (guix openpgp)
   #:use-module ((guix utils)
@@ -145,6 +146,27 @@ return a list of authorized fingerprints."
   "Return the list of OpenPGP fingerprints authorized to sign COMMIT, based on
 authorizations listed in its parent commits.  If one of the parent commits
 does not specify anything, fall back to DEFAULT-AUTHORIZATIONS."
+  (define (parents-have-authorizations-file? commit)
+    ;; Return true if at least one of the parents of COMMIT has the
+    ;; '.guix-authorizations' file.
+    (find (lambda (commit)
+            (false-if-git-not-found
+             (tree-entry-bypath (commit-tree commit)
+                                ".guix-authorizations")))
+          (commit-parents commit)))
+
+  (define (assert-parents-lack-authorizations commit)
+    ;; If COMMIT removes the '.guix-authorizations' file found in one of its
+    ;; parents, raise an error.
+    (when (parents-have-authorizations-file? commit)
+      (raise (condition
+              (&unauthorized-commit-error (commit (commit-id commit))
+                                          (signing-key #f))
+              (&message
+               (message (format #f (G_ "commit ~a attempts \
+to remove '.guix-authorizations' file")
+                                (oid->string (commit-id commit)))))))))
+
   (define (commit-authorizations commit)
     (catch 'git-error
       (lambda ()
@@ -155,7 +177,11 @@ does not specify anything, fall back to DEFAULT-AUTHORIZATIONS."
            (open-bytevector-input-port (blob-content blob)))))
       (lambda (key error)
         (if (= (git-error-code error) GIT_ENOTFOUND)
-            default-authorizations
+            (begin
+              ;; Prevent removal of '.guix-authorizations' since it would make
+              ;; it trivial to force a fallback to DEFAULT-AUTHORIZATIONS.
+              (assert-parents-lack-authorizations commit)
+              default-authorizations)
             (throw key error)))))
 
   (apply lset-intersection bytevector=?
diff --git a/guix/git.scm b/guix/git.scm
index ab3b5075b1..1671f57d9f 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -39,6 +39,7 @@
             honor-system-x509-certificates!
 
             with-repository
+            false-if-git-not-found
             update-cached-checkout
             url+commit->name
             latest-repository-commit
@@ -243,18 +244,23 @@ Return true on success, false on failure."
               (G_ "Support for submodules is missing; \
 please upgrade Guile-Git.~%"))))
 
+(define-syntax-rule (false-if-git-not-found exp)
+  "Evaluate EXP, returning #false if a GIT_ENOTFOUND error is raised."
+  (catch 'git-error
+    (lambda ()
+      exp)
+    (lambda (key error . rest)
+      (if (= GIT_ENOTFOUND (git-error-code error))
+          #f
+          (apply throw key error rest)))))
+
 (define (reference-available? repository ref)
   "Return true if REF, a reference such as '(commit . \"cabba9e\"), is
 definitely available in REPOSITORY, false otherwise."
   (match ref
     (('commit . commit)
-     (catch 'git-error
-       (lambda ()
-         (->bool (commit-lookup repository (string->oid commit))))
-       (lambda (key error . rest)
-         (if (= GIT_ENOTFOUND (git-error-code error))
-             #f
-             (apply throw key error rest)))))
+     (false-if-git-not-found
+      (->bool (commit-lookup repository (string->oid commit)))))
     (_
      #f)))
 
@@ -311,10 +317,13 @@ When RECURSIVE? is true, check out submodules as well, if any."
             (new      (and starting-commit
                            (commit-lookup repository oid)))
             (old      (and starting-commit
-                           (commit-lookup repository
-                                          (string->oid starting-commit))))
+                           (false-if-git-not-found
+                            (commit-lookup repository
+                                           (string->oid starting-commit)))))
             (relation (and starting-commit
-                           (commit-relation old new))))
+                           (if old
+                               (commit-relation old new)
+                               'unrelated))))
 
        ;; Reclaim file descriptors and memory mappings associated with
        ;; REPOSITORY as soon as possible.
diff --git a/guix/grafts.scm b/guix/grafts.scm
index 69d6fe4469..910dcadc8a 100644
--- a/guix/grafts.scm
+++ b/guix/grafts.scm
@@ -20,10 +20,12 @@
   #:use-module (guix store)
   #:use-module (guix monads)
   #:use-module (guix records)
+  #:use-module (guix combinators)
   #:use-module (guix derivations)
   #:use-module ((guix utils) #:select (%current-system))
   #:use-module (guix sets)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-9 gnu)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
@@ -183,32 +185,47 @@ references."
            (set-current-state (vhash-cons key result cache))
            (return result)))))))
 
-(define (reference-origin drv item)
-  "Return the derivation/output pair among the inputs of DRV, recursively,
-that produces ITEM.  Return #f if ITEM is not produced by a derivation (i.e.,
-it's a content-addressed \"source\"), or if it's not produced by a dependency
-of DRV."
+(define (reference-origins drv items)
+  "Return the derivation/output pairs among the inputs of DRV, recursively,
+that produce ITEMS.  Elements of ITEMS not produced by a derivation (i.e.,
+it's a content-addressed \"source\"), or not produced by a dependency of DRV,
+have no corresponding element in the resulting list."
+  (define (lookup-derivers drv result items)
+    ;; Return RESULT augmented by all the drv/output pairs producing one of
+    ;; ITEMS, and ITEMS stripped of matching items.
+    (fold2 (match-lambda*
+             (((output . file) result items)
+              (if (member file items)
+                  (values (alist-cons drv output result)
+                          (delete file items))
+                  (values result items))))
+           result items
+           (derivation->output-paths drv)))
+
   ;; Perform a breadth-first traversal of the dependency graph of DRV in
-  ;; search of the derivation that produces ITEM.
+  ;; search of the derivations that produce ITEMS.
   (let loop ((drv (list drv))
+             (items items)
+             (result '())
              (visited (setq)))
     (match drv
       (()
-       #f)
+       result)
       ((drv . rest)
-       (if (set-contains? visited drv)
-           (loop rest visited)
-           (let ((inputs (derivation-inputs drv)))
-             (or (any (lambda (input)
-                        (let ((drv (derivation-input-derivation input)))
-                          (any (match-lambda
-                                 ((output . file)
-                                  (and (string=? file item)
-                                       (cons drv output))))
-                               (derivation->output-paths drv))))
-                      inputs)
-                 (loop (append rest (map derivation-input-derivation inputs))
-                       (set-insert drv visited)))))))))
+       (cond ((null? items)
+              result)
+             ((set-contains? visited drv)
+              (loop rest items result visited))
+             (else
+              (let*-values (((inputs)
+                             (map derivation-input-derivation
+                                  (derivation-inputs drv)))
+                            ((result items)
+                             (fold2 lookup-derivers
+                                    result items inputs)))
+                (loop (append rest inputs)
+                      items result
+                      (set-insert drv visited)))))))))
 
 (define* (cumulative-grafts store drv grafts
                             #:key
@@ -233,25 +250,27 @@ derivations to the corresponding set of grafts."
       (_
        #f)))
 
-  (define (dependency-grafts item)
-    (match (reference-origin drv item)
-      ((drv . output)
-       ;; If GRAFTS already contains a graft from DRV, do not override it.
-       (if (find (cut graft-origin? drv <>) grafts)
-           (state-return grafts)
-           (cumulative-grafts store drv grafts
-                              #:outputs (list output)
-                              #:guile guile
-                              #:system system)))
-      (#f
-       (state-return grafts))))
+  (define (dependency-grafts items)
+    (mapm %store-monad
+          (lambda (drv+output)
+            (match drv+output
+              ((drv . output)
+               ;; If GRAFTS already contains a graft from DRV, do not
+               ;; override it.
+               (if (find (cut graft-origin? drv <>) grafts)
+                   (state-return grafts)
+                   (cumulative-grafts store drv grafts
+                                      #:outputs (list output)
+                                      #:guile guile
+                                      #:system system)))))
+          (reference-origins drv items)))
 
   (with-cache (cons (derivation-file-name drv) outputs)
     (match (non-self-references store drv outputs)
       (()                                         ;no dependencies
        (return grafts))
       (deps                                       ;one or more dependencies
-       (mlet %state-monad ((grafts (mapm %state-monad dependency-grafts deps)))
+       (mlet %state-monad ((grafts (dependency-grafts deps)))
          (let ((grafts (delete-duplicates (concatenate grafts) equal?)))
            (match (filter (lambda (graft)
                             (member (graft-origin-file-name graft) deps))
diff --git a/guix/packages.scm b/guix/packages.scm
index 3d9988d836..0ccd31a7a9 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1277,23 +1277,27 @@ to (see 'graft-derivation'.)"
 
   (define native-grafts
     (let ((->graft (input-graft store system)))
-      (fold-bag-dependencies (lambda (package grafts)
-                               (match (->graft package)
-                                 (#f    grafts)
-                                 (graft (cons graft grafts))))
-                             '()
-                             bag)))
+      (parameterize ((%current-system system)
+                     (%current-target-system #f))
+        (fold-bag-dependencies (lambda (package grafts)
+                                 (match (->graft package)
+                                   (#f    grafts)
+                                   (graft (cons graft grafts))))
+                               '()
+                               bag))))
 
   (define target-grafts
     (if target
         (let ((->graft (input-cross-graft store target system)))
-          (fold-bag-dependencies (lambda (package grafts)
-                                   (match (->graft package)
-                                     (#f    grafts)
-                                     (graft (cons graft grafts))))
-                                 '()
-                                 bag
-                                 #:native? #f))
+          (parameterize ((%current-system system)
+                         (%current-target-system target))
+            (fold-bag-dependencies (lambda (package grafts)
+                                     (match (->graft package)
+                                       (#f    grafts)
+                                       (graft (cons graft grafts))))
+                                   '()
+                                   bag
+                                   #:native? #f)))
         '()))
 
   ;; We can end up with several identical grafts if we stumble upon packages
diff --git a/guix/tests/git.scm b/guix/tests/git.scm
index c77c544e03..b8e5f7e643 100644
--- a/guix/tests/git.scm
+++ b/guix/tests/git.scm
@@ -21,7 +21,6 @@
   #:use-module ((guix git) #:select (with-repository))
   #:use-module (guix utils)
   #:use-module (guix build utils)
-  #:use-module ((guix tests gnupg) #:select (with-environment-variables))
   #:use-module (ice-9 match)
   #:use-module (ice-9 control)
   #:export (git-command
@@ -77,6 +76,9 @@ Return DIRECTORY on success."
                       port)))
          (git "add" file)
          (loop rest)))
+      ((('remove file) rest ...)
+       (git "rm" "-f" file)
+       (loop rest))
       ((('commit text) rest ...)
        (git "commit" "-m" text)
        (loop rest))
diff --git a/guix/tests/gnupg.scm b/guix/tests/gnupg.scm
index 6e7fdbcf65..47c858d232 100644
--- a/guix/tests/gnupg.scm
+++ b/guix/tests/gnupg.scm
@@ -22,27 +22,7 @@
   #:use-module (ice-9 match)
   #:export (gpg-command
             gpgconf-command
-            with-fresh-gnupg-setup
-
-            with-environment-variables))
-
-(define (call-with-environment-variables variables thunk)
-  "Call THUNK with the environment VARIABLES set."
-  (let ((environment (environ)))
-    (dynamic-wind
-      (lambda ()
-        (for-each (match-lambda
-                    ((variable value)
-                     (setenv variable value)))
-                  variables))
-      thunk
-      (lambda ()
-        (environ environment)))))
-
-(define-syntax-rule (with-environment-variables variables exp ...)
-  "Evaluate EXP with the given environment VARIABLES set."
-  (call-with-environment-variables variables
-                                   (lambda () exp ...)))
+            with-fresh-gnupg-setup))
 
 (define gpg-command
   (make-parameter "gpg"))
diff --git a/guix/ui.scm b/guix/ui.scm
index ea5f460865..98b30445c8 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -69,6 +69,7 @@
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
   #:use-module (ice-9 regex)
+  #:autoload   (ice-9 popen) (open-pipe* close-pipe)
   #:autoload   (system base compile) (compile-file)
   #:autoload   (system repl repl)  (start-repl)
   #:autoload   (system repl debug) (make-debug stack->vector)
@@ -1557,6 +1558,27 @@ score, the more relevant OBJ is to REGEXPS."
 zero means that PACKAGE does not match any of REGEXPS."
   (relevance package regexps %package-metrics))
 
+(define (call-with-paginated-output-port proc)
+  (if (isatty?* (current-output-port))
+      ;; Set 'LESS' so that 'less' exits if everything fits on the screen (F),
+      ;; lets ANSI escapes through (r), does not send the termcap
+      ;; initialization string (X).
+      (let ((pager (with-environment-variables `(("LESS"
+                                                  ,(or (getenv "LESS") "FrX")))
+                     (open-pipe* OPEN_WRITE
+                                 (or (getenv "GUIX_PAGER") (getenv "PAGER")
+                                     "less")))))
+        (dynamic-wind
+          (const #t)
+          (lambda () (proc pager))
+          (lambda () (close-pipe pager))))
+      (proc (current-output-port))))
+
+(define-syntax-rule (with-paginated-output-port port exp ...)
+  "Evaluate EXP... with PORT bound to a port that talks to the pager if
+standard output is a tty, or with PORT set to the current output port."
+  (call-with-paginated-output-port (lambda (port) exp ...)))
+
 (define* (display-search-results matches port
                                  #:key
                                  (command "guix search")
@@ -1573,30 +1595,17 @@ them.  If PORT is a terminal, print at most a full screen of results."
   (define (line-count str)
     (string-count str #\newline))
 
-  (let loop ((matches matches))
-    (match matches
-      (((package . score) rest ...)
-       (let* ((links? (supports-hyperlinks? port))
-              (text   (call-with-output-string
-                        (lambda (port)
-                          (print package port
-                                 #:hyperlinks? links?
-                                 #:extra-fields
-                                 `((relevance . ,score)))))))
-         (if (and (not (getenv "INSIDE_EMACS"))
-                  max-rows
-                  (> (port-line port) first-line) ;print at least one result
-                  (> (+ 4 (line-count text) (port-line port))
-                     max-rows))
-             (unless (null? rest)
-               (display-hint (format #f (G_ "Run @code{~a ... | less} \
-to view all the results.")
-                                     command)))
-             (begin
-               (display text port)
-               (loop rest)))))
-      (()
-       #t))))
+  (with-paginated-output-port paginated
+    (let loop ((matches matches))
+      (match matches
+        (((package . score) rest ...)
+         (let* ((links? (supports-hyperlinks? port)))
+           (print package paginated
+                  #:hyperlinks? links?
+                  #:extra-fields `((relevance . ,score)))
+           (loop rest)))
+        (()
+         #t)))))
 
 
 (define (string->generations str)
diff --git a/guix/utils.scm b/guix/utils.scm
index 69e3f0a934..17a96370f1 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -89,7 +89,6 @@
             guile-version>?
             version-prefix?
             string-replace-substring
-            arguments-from-environment-variable
             file-extension
             file-sans-extension
             tarball-sans-extension
@@ -99,6 +98,9 @@
             call-with-temporary-directory
             with-atomic-file-output
 
+            with-environment-variables
+            arguments-from-environment-variable
+
             config-directory
             cache-directory
 
@@ -115,6 +117,38 @@
 
 
 ;;;
+;;; Environment variables.
+;;;
+
+(define (call-with-environment-variables variables thunk)
+  "Call THUNK with the environment VARIABLES set."
+  (let ((environment (environ)))
+    (dynamic-wind
+      (lambda ()
+        (for-each (match-lambda
+                    ((variable value)
+                     (setenv variable value)))
+                  variables))
+      thunk
+      (lambda ()
+        (environ environment)))))
+
+(define-syntax-rule (with-environment-variables variables exp ...)
+  "Evaluate EXP with the given environment VARIABLES set."
+  (call-with-environment-variables variables
+                                   (lambda () exp ...)))
+
+(define (arguments-from-environment-variable variable)
+  "Retrieve value of environment variable denoted by string VARIABLE in the
+form of a list of strings (`char-set:graphic' tokens) suitable for consumption
+by `args-fold', if VARIABLE is defined, otherwise return an empty list."
+  (let ((env (getenv variable)))
+    (if env
+        (string-tokenize env char-set:graphic)
+        '())))
+
+
+;;;
 ;;; Filtering & pipes.
 ;;;
 
@@ -582,6 +616,11 @@ minor version numbers from version-string."
       (list-prefix? (string-tokenize v1 not-dot)
                     (string-tokenize v2 not-dot)))))
 
+
+;;;
+;;; Files.
+;;;
+
 (define (file-extension file)
   "Return the extension of FILE or #f if there is none."
   (let ((dot (string-rindex file #\.)))
@@ -634,15 +673,6 @@ REPLACEMENT."
                        (substring str start index)
                        pieces))))))))
 
-(define (arguments-from-environment-variable variable)
-  "Retrieve value of environment variable denoted by string VARIABLE in the
-form of a list of strings (`char-set:graphic' tokens) suitable for consumption
-by `args-fold', if VARIABLE is defined, otherwise return an empty list."
-  (let ((env (getenv variable)))
-    (if env
-        (string-tokenize env char-set:graphic)
-        '())))
-
 (define (call-with-temporary-output-file proc)
   "Call PROC with a name of a temporary file and open output port to that
 file; close the file and delete it when leaving the dynamic extent of this