Merge branch 'master' into staging

5 files changed, 56 insertions, 12 deletions

diff --git a/guix/hg-download.scm b/guix/hg-download.scm
index 694105ceba..bd55946523 100644
--- a/guix/hg-download.scm
+++ b/guix/hg-download.scm
@@ -26,12 +26,14 @@
   #:use-module (guix packages)
   #:autoload   (guix build-system gnu) (standard-packages)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 rdelim)
   #:export (hg-reference
             hg-reference?
             hg-reference-url
             hg-reference-changeset
             hg-reference-recursive?
-
+            hg-predicate
             hg-fetch))
 
 ;;; Commentary:
@@ -93,4 +95,38 @@ HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
                       #:recursive? #t
                       #:guile-for-build guile)))
 
+(define (hg-file-list directory)
+  "Evaluates to a list of files contained in the repository at path
+  @var{directory}"
+  (let* ((port (open-input-pipe (format #f "hg files --repository ~s" directory)))
+         (files (let loop ((files '()))
+                  (let ((line (read-line port)))
+                    (cond
+                     ((eof-object? line) files)
+                     (else
+                      (loop (cons line files))))))))
+    (close-pipe port)
+    (map canonicalize-path files)))
+
+(define (should-select? path-list candidate)
+  "Returns #t in case that @var{candidate} is a file that is part of the given
+@var{path-list}."
+  (let ((canon-candidate (canonicalize-path candidate)))
+    (let loop ((xs path-list))
+      (cond
+       ((null? xs)
+        ;; Directories are not part of `hg files', but `local-file' will not
+        ;; recurse if we don't return #t for directories.
+        (equal? (array-ref (lstat candidate) 13) 'directory))
+       ((string-contains candidate (car xs)) #t)
+       (else (loop (cdr xs)))))))
+
+(define (hg-predicate directory)
+  "This procedure evaluates to a predicate that reports back whether a given
+@var{file} - @var{stat} combination is part of the files tracked by
+Mercurial."
+  (let ((files (hg-file-list directory)))
+    (lambda (file stat)
+      (should-select? files file))))
+
 ;;; hg-download.scm ends here
diff --git a/guix/lint.scm b/guix/lint.scm
index e1a77e8ac7..91dbc806dc 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -663,17 +663,11 @@ from ~a")
 (define (check-patch-file-names package)
   "Emit a warning if the patches requires by PACKAGE are badly named or if the
 patch could not be found."
-  (guard (c ((message-condition? c)     ;raised by 'search-patch'
-             (list
-              ;; Use %make-warning, as condition-mesasge is already
-              ;; translated.
-              (%make-warning package (condition-message c)
-                             #:field 'patch-file-names)))
-            ((formatted-message? c)
+  (guard (c ((formatted-message? c)               ;raised by 'search-patch'
              (list (%make-warning package
-                                  (apply format #f
-                                         (G_ (formatted-message-string c))
-                                         (formatted-message-arguments c))))))
+                                  (formatted-message-string c)
+                                  (formatted-message-arguments c)
+                                  #:field 'source))))
     (define patches
       (match (package-source package)
         ((? origin? origin) (origin-patches origin))
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm
index 02557ce454..c04baf9784 100644
--- a/guix/scripts/archive.scm
+++ b/guix/scripts/archive.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -310,6 +311,16 @@ the input port."
         (leave (G_ "failed to read public key: ~a: ~a~%")
                (error-source err) (error-string err)))))
 
+  ;; Warn about potentially volatile ACLs, but continue: system reconfiguration
+  ;; might not be possible without (newly-authorized) substitutes.
+  (let ((stat (false-if-exception (lstat %acl-file))))
+    (when (and stat (eq? 'symlink (stat:type (lstat %acl-file))))
+      (warning (G_ "replacing symbolic link ~a with a regular file~%")
+               %acl-file)
+      (when (string-prefix? (%store-prefix) (readlink %acl-file))
+        (display-hint (G_ "On Guix System, add public keys to the
+@code{authorized-keys} field of your @code{operating-system} instead.")))))
+
   (let ((key (read-key))
         (acl (current-acl)))
     (unless (eq? 'public-key (canonical-sexp-nth-data key 0))
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index e3c8711f5b..a976a9ac60 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -891,6 +891,8 @@ blocking."
                                             client))
                (port        (begin
                               (force-output client)
+                              (setsockopt client SOL_SOCKET
+                                          SO_SNDBUF (* 128 1024))
                               (nar-response-port response compression))))
           ;; XXX: Given our ugly workaround for <http://bugs.gnu.org/21093> in
           ;; 'render-nar', BODY here is just the file name of the store item.
diff --git a/guix/ui.scm b/guix/ui.scm
index 8d7bc238bc..4e686297e8 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -435,6 +435,7 @@ exiting.  ARGS is the list of arguments received by the 'throw' handler."
                      (gettext (condition-message obj) %gettext-domain)))
            ((formatted-message? obj)
             (warning (G_ "failed to load '~a': ~a~%")
+                     file
                      (apply format #f
                             (gettext (formatted-message-string obj)
                                      %gettext-domain)
@@ -717,7 +718,7 @@ evaluating the tests and bodies of CLAUSES."
                        (package-full-name package)
                        (build-system-name system))))
              ((gexp-input-error? c)
-              (let ((input (package-error-invalid-input c)))
+              (let ((input (gexp-error-invalid-input c)))
                 (leave (G_ "~s: invalid G-expression input~%")
                        (gexp-error-invalid-input c))))
              ((profile-not-found-error? c)