Merge remote-tracking branch 'signed/master' into core-updates

11 files changed, 239 insertions, 118 deletions

diff --git a/guix/build-system/go.scm b/guix/build-system/go.scm
index b62f2a897b..8cdcb61028 100644
--- a/guix/build-system/go.scm
+++ b/guix/build-system/go.scm
@@ -166,8 +166,8 @@ commit hash and its date rather than a proper release tag."
                    (tests? #t)
                    (allow-go-reference? #f)
                    (system (%current-system))
-                   (goarch (first (go-target (%current-system))))
-                   (goos (last (go-target (%current-system))))
+                   (goarch #f)
+                   (goos #f)
                    (guile #f)
                    (imported-modules %go-build-system-modules)
                    (modules '((guix build go-build-system)
diff --git a/guix/build/download.scm b/guix/build/download.scm
index fd8fe69901..7c310e94f1 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -36,7 +36,7 @@
   #:use-module (srfi srfi-26)
   #:autoload   (ice-9 ftw) (scandir)
   #:autoload   (guix base16) (bytevector->base16-string)
-  #:autoload   (guix swh) (swh-download-directory)
+  #:autoload   (guix swh) (swh-download-directory %verify-swh-certificate?)
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
   #:export (open-socket-for-uri
@@ -646,6 +646,8 @@ and write the output to FILE."
                                                   #:verify-certificate?
                                                   verify-certificate?
                                                   #:timeout timeout)))
+              (format #t "Retrieving Disarchive spec from ~a ...~%"
+                      (uri->string uri))
               (let ((specification (read port)))
                 (close-port port)
                 specification))))
diff --git a/guix/build/go-build-system.scm b/guix/build/go-build-system.scm
index 645d2fe680..4768ee8562 100644
--- a/guix/build/go-build-system.scm
+++ b/guix/build/go-build-system.scm
@@ -152,8 +152,10 @@ dependencies, so it should be self-contained."
 
   ;; Make sure we're building for the correct architecture and OS targets
   ;; that Guix targets.
-  (setenv "GOARCH" goarch)
-  (setenv "GOOS" goos)
+  (setenv "GOARCH" (or goarch
+                       (getenv "GOHOSTARCH")))
+  (setenv "GOOS" (or goos
+                     (getenv "GOHOSTOS")))
   (match goarch
     ("arm"
      (setenv "GOARM" "7"))
diff --git a/guix/build/minetest-build-system.scm b/guix/build/minetest-build-system.scm
index 477cc3d1d0..5f68686067 100644
--- a/guix/build/minetest-build-system.scm
+++ b/guix/build/minetest-build-system.scm
@@ -23,6 +23,7 @@
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 receive)
   #:use-module (ice-9 regex)
+  #:use-module (ice-9 exceptions)
   #:use-module ((guix build gnu-build-system) #:prefix gnu:)
   #:use-module ((guix build copy-build-system) #:prefix copy:)
   #:export (%standard-phases
@@ -40,7 +41,7 @@
      ;; See <https://github.com/minetest/minetest/blob/master/doc/lua_api.txt>
      ;; for an incomple list of files that can be found in mods.
      #:include ("mod.conf" "modpack.conf" "settingtypes.txt" "depends.txt"
-                "description.txt")
+                "description.txt" "config.txt" "_config.txt")
      #:include-regexp (".lua$" ".png$" ".ogg$" ".obj$" ".b3d$" ".tr$"
                        ".mts$"))))
 
@@ -199,20 +200,24 @@ auth_backend = sqlite3
         (define (stop? line)
           (and (string? line)
                (string-contains line "ACTION[Server]: singleplayer [127.0.0.1] joins game.")))
-        (let loop ()
-          (match (read-line port)
-            ((? error? line)
-             (error "minetest raised an error: ~a" line))
-            ((? stop?)
+        (let loop ((has-errors? #f))
+          (match `(,(read-line port) ,has-errors?)
+            (((? error? line) _)
+             (display line)
+             (newline)
+             (loop #t))
+            (((? stop?) #f)
              (kill pid SIGINT)
              (close-port port)
              (waitpid pid))
-            ((? string? line)
+            (((? eof-object?) #f)
+             (error "minetest didn't start"))
+            (((or (? stop?) (? eof-object?)) #t)
+             (error "minetest raised an error"))
+            (((? string? line) has-error?)
              (display line)
              (newline)
-             (loop))
-            ((? eof-object?)
-             (error "minetest didn't start"))))))))
+             (loop has-error?))))))))
 
 (define %standard-phases
   (modify-phases gnu:%standard-phases
diff --git a/guix/build/po.scm b/guix/build/po.scm
index eb9690ad1a..7f88164cd8 100644
--- a/guix/build/po.scm
+++ b/guix/build/po.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu>
+;;; Copyright © 2019, 2021 Julien Lepiller <julien@lepiller.eu>
 ;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -20,17 +20,23 @@
 (define-module (guix build po)
   #:use-module (ice-9 match)
   #:use-module (ice-9 peg)
+  #:use-module (ice-9 regex)
   #:use-module (ice-9 textual-ports)
-  #:export (read-po-file))
+  #:use-module (ice-9 vlist)
+  #:use-module (srfi srfi-1)
+  #:export (read-po-file
+            translate-cross-references))
 
 ;; A small parser for po files
-(define-peg-pattern po-file body (* (or comment entry whitespace)))
+(define-peg-pattern po-file body (* (or entry whitespace)))
 (define-peg-pattern whitespace body (or " " "\t" "\n"))
 (define-peg-pattern comment-chr body (range #\space #\頋))
 (define-peg-pattern comment none (and "#" (* comment-chr) "\n"))
+(define-peg-pattern flags all (and (ignore "#, ") (* comment-chr) (ignore "\n")))
 (define-peg-pattern entry all
-  (and (ignore (* whitespace)) (ignore "msgid ") msgid
-       (ignore (* whitespace)) (ignore "msgstr ") msgstr))
+  (and (* (or flags comment (ignore (* whitespace))))
+       (ignore "msgid ") msgid (ignore (* whitespace))
+       (ignore "msgstr ") msgstr))
 (define-peg-pattern escape body (or "\\\\" "\\\"" "\\n"))
 (define-peg-pattern str-chr body (or " " "!" (and (ignore "\\") "\"")
                                      "\\n" (and (ignore "\\") "\\")
@@ -53,7 +59,24 @@
                (append (list "\n" prefix) result)))))))
 
 (define (parse-tree->assoc parse-tree)
-  "Converts a po PARSE-TREE to an association list."
+  "Converts a po PARSE-TREE to an association list, where the key is the msgid
+and the value is the msgstr.  The result only contains non fuzzy strings."
+  (define (comments->flags comments)
+    (match comments
+      (('flags flags)
+       (map (lambda (flag) (string->symbol (string-trim-both flag #\space)))
+            (string-split flags #\,)))
+      ((? list? comments)
+       (fold
+         (lambda (comment res)
+           (match comment
+             ((? string? _) res)
+             (flags
+              (append (comments->flags flags)
+                      res))))
+         '()
+         comments))))
+
   (match parse-tree
     (() '())
     ((entry . parse-tree)
@@ -66,10 +89,22 @@
        ;; empty msgstr
        (('entry ('msgid msgid) 'msgstr)
         (parse-tree->assoc parse-tree))
+       (('entry _ ('msgid msgid) 'msgstr)
+        (parse-tree->assoc parse-tree))
+       (('entry ('msgid msgid) ('msgstr msgstr))
+        (acons (interpret-newline-escape msgid)
+               (interpret-newline-escape msgstr)
+               (parse-tree->assoc parse-tree)))
        (('entry ('msgid msgid) ('msgstr msgstr))
         (acons (interpret-newline-escape msgid)
                (interpret-newline-escape msgstr)
-               (parse-tree->assoc parse-tree)))))))
+               (parse-tree->assoc parse-tree)))
+       (('entry comments ('msgid msgid) ('msgstr msgstr))
+        (if (member 'fuzzy (comments->flags comments))
+            (parse-tree->assoc parse-tree)
+            (acons (interpret-newline-escape msgid)
+                   (interpret-newline-escape msgstr)
+                   (parse-tree->assoc parse-tree))))))))
 
 (define (read-po-file port)
   "Read a .po file from PORT and return an alist of msgid and msgstr."
@@ -77,3 +112,71 @@
                           po-file
                           (get-string-all port)))))
     (parse-tree->assoc tree)))
+
+(define (canonicalize-whitespace str)
+  "Change whitespace (newlines, etc.) in STR to @code{#\\space}."
+  (string-map (lambda (chr)
+                (if (char-set-contains? char-set:whitespace chr)
+                    #\space
+                    chr))
+              str))
+
+(define xref-regexp
+  ;; Texinfo cross-reference regexp.
+  (make-regexp "@(px|x)?ref\\{([^,}]+)"))
+
+(define (translate-cross-references texi pofile)
+  "Translate the cross-references that appear in @var{texi}, the initial
+translation of a Texinfo file, using the msgid/msgstr pairs from @var{pofile}."
+  (define translations
+    (call-with-input-file pofile read-po-file))
+
+  (define content
+    (call-with-input-file texi get-string-all))
+
+  (define matches
+    (list-matches xref-regexp content))
+
+  (define translation-map
+    (fold (match-lambda*
+            (((msgid . str) result)
+             (vhash-cons msgid str result)))
+          vlist-null
+          translations))
+
+  (define translated
+    ;; Iterate over MATCHES and replace cross-references with their
+    ;; translation found in TRANSLATION-MAP.  (We can't use
+    ;; 'substitute*' because matches can span multiple lines.)
+    (let loop ((matches matches)
+               (offset 0)
+               (result '()))
+      (match matches
+        (()
+         (string-concatenate-reverse
+          (cons (string-drop content offset) result)))
+        ((head . tail)
+         (let ((prefix (match:substring head 1))
+               (ref    (canonicalize-whitespace (match:substring head 2))))
+           (define translated
+             (string-append "@" (or prefix "")
+                            "ref{"
+                            (match (vhash-assoc ref translation-map)
+                              (#f ref)
+                              ((_ . str) str))))
+
+           (loop tail
+                 (match:end head)
+                 (append (list translated
+                               (string-take
+                                (string-drop content offset)
+                                (- (match:start head) offset)))
+                         result)))))))
+
+  (format (current-error-port)
+          "translated ~a cross-references in '~a'~%"
+          (length matches) texi)
+
+  (call-with-output-file texi
+    (lambda (port)
+      (display translated port))))
diff --git a/guix/download.scm b/guix/download.scm
index 85b97a4766..4e219c9f49 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -36,6 +36,7 @@
   #:use-module (srfi srfi-26)
   #:export (%mirrors
             %disarchive-mirrors
+            %download-fallback-test
             (url-fetch* . url-fetch)
             url-fetch/executable
             url-fetch/tarbomb
@@ -399,14 +400,23 @@
   (plain-file "content-addressed-mirrors"
               (object->string %content-addressed-mirrors)))
 
+(define %no-mirrors-file
+  ;; File specifying an empty list of mirrors, for fallback tests.
+  (plain-file "no-content-addressed-mirrors" (object->string ''())))
+
 (define %disarchive-mirrors
   ;; TODO: Eventually turn into a procedure that takes a hash algorithm
   ;; (symbol) and hash (bytevector).
-  '("https://disarchive.ngyro.com/"))
+  '("https://disarchive.guix.gnu.org/"
+    "https://disarchive.ngyro.com/"))
 
 (define %disarchive-mirror-file
   (plain-file "disarchive-mirrors" (object->string %disarchive-mirrors)))
 
+(define %no-disarchive-mirrors-file
+  ;; File specifying an empty list of Disarchive mirrors, for fallback tests.
+  (plain-file "no-disarchive-mirrors" (object->string '())))
+
 (define built-in-builders*
   (store-lift built-in-builders))
 
@@ -455,6 +465,24 @@ download by itself using its own dependencies."
                     ;; for that built-in is widespread.
                     #:local-build? #t)))
 
+(define %download-fallback-test
+  ;; Define whether to test one of the download fallback mechanism.  Possible
+  ;; values are:
+  ;;
+  ;;   - #f, to use the normal download methods, not trying to exercise the
+  ;;     fallback mechanism;
+  ;;
+  ;;   - 'none, to disable all the fallback mechanisms;
+  ;;
+  ;;   - 'content-addressed-mirrors, to purposefully attempt to download from
+  ;;     a content-addressed mirror;
+  ;;
+  ;;   - 'disarchive-mirrors, to download from Disarchive + Software Heritage.
+  ;;
+  ;; This is meant to be used for testing purposes.
+  (make-parameter (and=> (getenv "GUIX_DOWNLOAD_FALLBACK_TEST")
+                         string->symbol)))
+
 (define* (url-fetch* url hash-algo hash
                      #:optional name
                      #:key (system (%current-system))
@@ -490,7 +518,10 @@ name in the store."
           (unless (member "download" builtins)
             (error "'guix-daemon' is too old, please upgrade" builtins))
 
-          (built-in-download (or name file-name) url
+          (built-in-download (or name file-name)
+                             (match (%download-fallback-test)
+                               ((or #f 'none) url)
+                               (_ "https://example.org/does-not-exist"))
                              #:guile guile
                              #:system system
                              #:hash-algo hash-algo
@@ -498,9 +529,15 @@ name in the store."
                              #:executable? executable?
                              #:mirrors %mirror-file
                              #:content-addressed-mirrors
-                             %content-addressed-mirror-file
+                             (match (%download-fallback-test)
+                               ((or #f 'content-addressed-mirrors)
+                                %content-addressed-mirror-file)
+                               (_ %no-mirrors-file))
                              #:disarchive-mirrors
-                             %disarchive-mirror-file)))))
+                             (match (%download-fallback-test)
+                               ((or #f 'disarchive-mirrors)
+                                %disarchive-mirror-file)
+                               (_ %no-disarchive-mirrors-file)))))))
 
 (define* (url-fetch/executable url hash-algo hash
                                #:optional name
diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm
index e2314820d0..d5035b790b 100644
--- a/guix/import/pypi.scm
+++ b/guix/import/pypi.scm
@@ -419,7 +419,7 @@ return the unaltered list of upstream dependency names."
   "Return the `package' s-expression for a python package with the given NAME,
 VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE."
   (define (maybe-upstream-name name)
-    (if (string-match ".*\\-[0-9]+" (pk name))
+    (if (string-match ".*\\-[0-9]+" name)
         `((properties ,`'(("upstream-name" . ,name))))
         '()))
   
@@ -533,9 +533,12 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE."
                   (url     (distribution-url
                             (latest-source-release pypi-package))))
              (upstream-source
+              (urls (list url))
+              (input-changes
+               (changed-inputs package
+                               (pypi->guix-package pypi-name)))
               (package (package-name package))
-              (version version)
-              (urls (list url))))))))
+              (version version)))))))
 
 (define %pypi-updater
   (upstream-updater
diff --git a/guix/lint.scm b/guix/lint.scm
index 217a0d6696..5edb9dea28 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -1588,7 +1588,7 @@ Heritage and missing from the Disarchive database")
                          (#f '())
                          (id
                           (list (make-warning package
-                                              (G_ "
+                                              (G_ "\
 Disarchive entry refers to non-existent SWH directory '~a'")
                                               (list id)
                                               #:field 'source)))))))
diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index fb6c52a567..8806f0f740 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
 ;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
@@ -329,23 +329,39 @@ warn about packages that have no matching updater."
                       (package-version package) version)
                 (for-each
                  (lambda (change)
-                   (format (current-error-port)
-                           (match (list (upstream-input-change-action change)
-                                        (upstream-input-change-type change))
-                             (('add 'regular)
-                              (G_ "~a: consider adding this input: ~a~%"))
-                             (('add 'native)
-                              (G_ "~a: consider adding this native input: ~a~%"))
-                             (('add 'propagated)
-                              (G_ "~a: consider adding this propagated input: ~a~%"))
-                             (('remove 'regular)
-                              (G_ "~a: consider removing this input: ~a~%"))
-                             (('remove 'native)
-                              (G_ "~a: consider removing this native input: ~a~%"))
-                             (('remove 'propagated)
-                              (G_ "~a: consider removing this propagated input: ~a~%")))
-                           (package-name package)
-                           (upstream-input-change-name change)))
+                   (define field
+                     (match (upstream-input-change-type change)
+                       ('native 'native-inputs)
+                       ('propagated 'propagated-inputs)
+                       (_ 'inputs)))
+
+                   (define name
+                     (package-name package))
+                   (define loc
+                     (package-field-location package field))
+                   (define change-name
+                     (upstream-input-change-name change))
+
+                   (match (list (upstream-input-change-action change)
+                                (upstream-input-change-type change))
+                     (('add 'regular)
+                      (info loc (G_ "~a: consider adding this input: ~a~%")
+                            name change-name))
+                     (('add 'native)
+                      (info loc (G_ "~a: consider adding this native input: ~a~%")
+                            name change-name))
+                     (('add 'propagated)
+                      (info loc (G_ "~a: consider adding this propagated input: ~a~%")
+                            name change-name))
+                     (('remove 'regular)
+                      (info loc (G_ "~a: consider removing this input: ~a~%")
+                            name change-name))
+                     (('remove 'native)
+                      (info loc (G_ "~a: consider removing this native input: ~a~%")
+                            name change-name))
+                     (('remove 'propagated)
+                      (info loc (G_ "~a: consider removing this propagated input: ~a~%")
+                            name change-name))))
                  (upstream-source-input-changes source))
                 (let ((hash (call-with-input-file tarball
                               port-sha256)))
diff --git a/guix/self.scm b/guix/self.scm
index a0d448742a..bd9a71de45 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -316,81 +316,23 @@ the result to OUTPUT."
                               chr))
                         str))
 
-          (define xref-regexp
-            ;; Texinfo cross-reference regexp.
-            (make-regexp "@(px|x)?ref\\{([^,}]+)"))
-
-          (define (translate-cross-references texi translations)
-            ;; Translate the cross-references that appear in TEXI, a Texinfo
-            ;; file, using the msgid/msgstr pairs from TRANSLATIONS.
-            (define content
-              (call-with-input-file texi get-string-all))
-
-            (define matches
-              (list-matches xref-regexp content))
-
-            (define translation-map
-              (fold (match-lambda*
-                      (((msgid . str) result)
-                       (vhash-cons msgid str result)))
-                    vlist-null
-                    translations))
-
-            (define translated
-              ;; Iterate over MATCHES and replace cross-references with their
-              ;; translation found in TRANSLATION-MAP.  (We can't use
-              ;; 'substitute*' because matches can span multiple lines.)
-              (let loop ((matches matches)
-                         (offset 0)
-                         (result '()))
-                (match matches
-                  (()
-                   (string-concatenate-reverse
-                    (cons (string-drop content offset) result)))
-                  ((head . tail)
-                   (let ((prefix (match:substring head 1))
-                         (ref    (canonicalize-whitespace (match:substring head 2))))
-                     (define translated
-                       (string-append "@" (or prefix "")
-                                      "ref{"
-                                      (match (vhash-assoc ref translation-map)
-                                        (#f ref)
-                                        ((_ . str) str))))
-
-                     (loop tail
-                           (match:end head)
-                           (append (list translated
-                                         (string-take
-                                          (string-drop content offset)
-                                          (- (match:start head) offset)))
-                                   result)))))))
-
-            (format (current-error-port)
-                    "translated ~a cross-references in '~a'~%"
-                    (length matches) texi)
-            (call-with-output-file texi
-              (lambda (port)
-                (display translated port))))
-
           (define* (translate-texi prefix po lang
                                    #:key (extras '()))
             "Translate the manual for one language LANG using the PO file.
 PREFIX must be the prefix of the manual, 'guix' or 'guix-cookbook'.  EXTRAS is
 a list of extra files, such as '(\"contributing\")."
-            (let ((translations (call-with-input-file po read-po-file)))
-              (for-each (lambda (file)
-                          (translate-tmp-texi po (string-append file ".texi")
-                                              (string-append file "." lang
-                                                             ".texi.tmp")))
-                        (cons prefix extras))
-
-              (for-each (lambda (file)
-                          (let* ((texi (string-append file "." lang ".texi"))
-                                 (tmp  (string-append texi ".tmp")))
-                            (copy-file tmp texi)
-                            (translate-cross-references texi
-                                                        translations)))
-                        (cons prefix extras))))
+            (for-each (lambda (file)
+                        (translate-tmp-texi po (string-append file ".texi")
+                                            (string-append file "." lang
+                                                           ".texi.tmp")))
+                      (cons prefix extras))
+
+            (for-each (lambda (file)
+                        (let* ((texi (string-append file "." lang ".texi"))
+                               (tmp  (string-append texi ".tmp")))
+                          (copy-file tmp texi)
+                          (translate-cross-references texi po)))
+                      (cons prefix extras)))
 
           (define (available-translations directory domain)
             ;; Return the list of available translations under DIRECTORY for
diff --git a/guix/swh.scm b/guix/swh.scm
index 5c41685a24..c7c1c873a2 100644
--- a/guix/swh.scm
+++ b/guix/swh.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
 ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
+;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -136,6 +137,12 @@
   ;; Whether to verify the X.509 HTTPS certificate for %SWH-BASE-URL.
   (make-parameter #t))
 
+;; Token from an account to the Software Heritage Authentication service
+;; <https://archive.softwareheritage.org/api/>
+(define %swh-token
+  (make-parameter (and=> (getenv "GUIX_SWH_TOKEN")
+                         string->symbol)))
+
 (define (swh-url path . rest)
   ;; URLs returned by the API may be relative or absolute. This has changed
   ;; without notice before. Handle both cases by detecting whether the path
@@ -246,6 +253,10 @@ FALSE-IF-404? is true, return #f upon 404 responses."
   (and ((%allow-request?) url method)
        (let*-values (((response port)
                       (method url #:streaming? #t
+                              #:headers
+                              (if (%swh-token)
+                                  `((authorization . (Bearer ,(%swh-token))))
+                                  '())
                               #:verify-certificate?
                               (%verify-swh-certificate?))))
          ;; See <https://archive.softwareheritage.org/api/#rate-limiting>.