Merge branch 'staging' into core-updates

5 files changed, 123 insertions, 110 deletions

diff --git a/guix/build/asdf-build-system.scm b/guix/build/asdf-build-system.scm
index 6186613e52..92154e7d34 100644
--- a/guix/build/asdf-build-system.scm
+++ b/guix/build/asdf-build-system.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca>
-;;; Copyright © 2020, 2021 Guillaume Le Vaillant <glv@posteo.net>
+;;; Copyright © 2020, 2021, 2022 Guillaume Le Vaillant <glv@posteo.net>
+;;; Copyright © 2022 Pierre Neidhardt <mail@ambrevar.xyz>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -78,16 +79,6 @@
     (,(library-directory object-output)
      :**/ :*.*.*)))
 
-(define (source-asd-file output name asd-file)
-  (string-append (lisp-source-directory output name) "/" asd-file))
-
-(define (find-asd-files output name asd-files)
-  (if (null? asd-files)
-      (find-files (lisp-source-directory output name) "\\.asd$")
-      (map (lambda (asd-file)
-             (source-asd-file output name asd-file))
-           asd-files)))
-
 (define (copy-files-to-output out name)
   "Copy all files from the current directory to OUT.  Create an extra link to
 any system-defining files in the source to a convenient location.  This is
@@ -190,7 +181,7 @@ if it's present in the native-inputs."
     (setenv "XDG_CONFIG_DIRS" (string-append out "/etc")))
   #t)
 
-(define* (build #:key outputs inputs asd-files asd-systems
+(define* (build #:key outputs inputs asd-systems asd-operation
                 #:allow-other-keys)
   "Compile the system."
   (let* ((out (library-output outputs))
@@ -198,26 +189,22 @@ if it's present in the native-inputs."
          (source-path (string-append out (%lisp-source-install-prefix)))
          (translations (wrap-output-translations
                         `(,(output-translation source-path
-                                               out))))
-         (asd-files (find-asd-files out system-name asd-files)))
+                                               out)))))
     (setenv "ASDF_OUTPUT_TRANSLATIONS"
             (replace-escaped-macros (format #f "~S" translations)))
     (setenv "HOME" out) ; ecl's asdf sometimes wants to create $HOME/.cache
-    (compile-systems asd-systems asd-files))
+    (compile-systems asd-systems
+                     (lisp-source-directory out system-name)
+                     asd-operation))
   #t)
 
-(define* (check #:key tests? outputs inputs asd-files asd-systems
-                test-asd-file
+(define* (check #:key tests? outputs inputs asd-test-systems
                 #:allow-other-keys)
   "Test the system."
   (let* ((out (library-output outputs))
-         (system-name (main-system-name out))
-         (asd-files (find-asd-files out system-name asd-files))
-         (test-asd-file
-          (and=> test-asd-file
-                 (cut source-asd-file out system-name <>))))
+         (system-name (main-system-name out)))
     (if tests?
-        (test-system (first asd-systems) asd-files test-asd-file)
+        (test-system asd-test-systems (lisp-source-directory out system-name))
         (format #t "test suite not run~%")))
   #t)
 
diff --git a/guix/build/download.scm b/guix/build/download.scm
index 41583e8143..db0a39084b 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -245,6 +245,54 @@ way."
 (set-exception-printer! 'tls-certificate-error
                         print-tls-certificate-error)
 
+(define (wrap-record-port-for-gnutls<3.7.7 record port)
+  "Return a port that wraps RECORD to ensure that closing it also closes PORT,
+the actual socket port, and its file descriptor.  Make sure it does not
+introduce extra buffering (custom ports are buffered by default as of Guile
+3.0.5).
+
+This wrapper is unnecessary with GnuTLS >= 3.7.7, which can automatically
+close SESSION's file descriptor when RECORD is closed."
+  (define (read! bv start count)
+    (define read
+      (catch 'gnutls-error
+        (lambda ()
+          (get-bytevector-n! record bv start count))
+        (lambda (key err proc . rest)
+          ;; When responding to "Connection: close" requests, some servers
+          ;; close the connection abruptly after sending the response body,
+          ;; without doing a proper TLS connection termination.  Treat it as
+          ;; EOF.  This is fixed in GnuTLS 3.7.7.
+          (if (eq? err error/premature-termination)
+              the-eof-object
+              (apply throw key err proc rest)))))
+
+    (if (eof-object? read)
+        0
+        read))
+  (define (write! bv start count)
+    (put-bytevector record bv start count)
+    (force-output record)
+    count)
+  (define (get-position)
+    (port-position record))
+  (define (set-position! new-position)
+    (set-port-position! record new-position))
+  (define (close)
+    (unless (port-closed? port)
+      (close-port port))
+    (unless (port-closed? record)
+      (close-port record)))
+
+  (define (unbuffered port)
+    (setvbuf port 'none)
+    port)
+
+  (unbuffered
+   (make-custom-binary-input/output-port "gnutls wrapped port" read! write!
+                                         get-position set-position!
+                                         close)))
+
 (define* (tls-wrap port server #:key (verify-certificate? #t))
   "Return PORT wrapped in a TLS connection to SERVER.  SERVER must be a DNS
 host name without trailing dot."
@@ -317,55 +365,13 @@ host name without trailing dot."
           (apply throw args))))
 
     (let ((record (session-record-port session)))
-      (define (read! bv start count)
-        (define read
-          (catch 'gnutls-error
-            (lambda ()
-              (get-bytevector-n! record bv start count))
-            (lambda (key err proc . rest)
-              ;; When responding to "Connection: close" requests, some
-              ;; servers close the connection abruptly after sending the
-              ;; response body, without doing a proper TLS connection
-              ;; termination.  Treat it as EOF.
-              (if (eq? err error/premature-termination)
-                  the-eof-object
-                  (apply throw key err proc rest)))))
-
-        (if (eof-object? read)
-            0
-            read))
-      (define (write! bv start count)
-        (put-bytevector record bv start count)
-        (force-output record)
-        count)
-      (define (get-position)
-        (port-position record))
-      (define (set-position! new-position)
-        (set-port-position! record new-position))
-      (define (close)
-        (unless (port-closed? port)
-          (close-port port))
-        (unless (port-closed? record)
-          (close-port record)))
-
-      (define (unbuffered port)
-        (setvbuf port 'none)
-        port)
-
       (setvbuf record 'block)
-
-      ;; Return a port that wraps RECORD to ensure that closing it also
-      ;; closes PORT, the actual socket port, and its file descriptor.
-      ;; Make sure it does not introduce extra buffering (custom ports
-      ;; are buffered by default as of Guile 3.0.5).
-      ;; XXX: This wrapper would be unnecessary if GnuTLS could
-      ;; automatically close SESSION's file descriptor when RECORD is
-      ;; closed, but that doesn't seem to be possible currently (as of
-      ;; 3.6.9).
-      (unbuffered
-       (make-custom-binary-input/output-port "gnutls wrapped port" read! write!
-                                             get-position set-position!
-                                             close)))))
+      (if (module-defined? (resolve-interface '(gnutls))
+                           'set-session-record-port-close!) ;GnuTLS >= 3.7.7
+          (let ((close-wrapped-port (lambda (_) (close-port port))))
+            (set-session-record-port-close! record close-wrapped-port)
+            record)
+          (wrap-record-port-for-gnutls<3.7.7 record port)))))
 
 (define (ensure-uri uri-or-string)                ;XXX: copied from (web http)
   (cond
@@ -744,6 +750,7 @@ otherwise simply ignore them."
                                          (progress-reporter/file
                                           (uri-abbreviation uri) size)))
               (newline)))
+          (close-port port)
           file)))
       ((ftp)
        (false-if-exception* (ftp-fetch uri file
diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm
index 17d2637f87..646d4a3365 100644
--- a/guix/build/lisp-utils.scm
+++ b/guix/build/lisp-utils.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca>
-;;; Copyright © 2020 Guillaume Le Vaillant <glv@posteo.net>
+;;; Copyright © 2020, 2022 Guillaume Le Vaillant <glv@posteo.net>
+;;; Copyright © 2022 Pierre Neidhardt <mail@ambrevar.xyz>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -107,38 +108,31 @@ with PROGRAM."
              "--eval" "(quit)"))
     (_ (error "The LISP provided is not supported at this time."))))
 
-(define (compile-systems systems asd-files)
-  "Use a lisp implementation to compile the SYSTEMS using asdf.
-Load ASD-FILES first."
+(define (compile-systems systems directory operation)
+  "Use a lisp implementation to compile the SYSTEMS using asdf."
   (lisp-eval-program
    `((require :asdf)
-     ,@(map (lambda (asd-file)
-              `(asdf:load-asd (truename ,asd-file)))
-            asd-files)
+     (asdf:initialize-source-registry
+      (list :source-registry (list :tree (uiop:ensure-pathname ,directory
+                                                               :truenamize t
+                                                               :ensure-directory t))
+            :inherit-configuration))
      ,@(map (lambda (system)
-              `(asdf:compile-system ,system))
+              (list (string->symbol (string-append "asdf:" operation)) system))
             systems))))
 
-(define (test-system system asd-files test-asd-file)
-  "Use a lisp implementation to test SYSTEM using asdf.  Load ASD-FILES first.
-Also load TEST-ASD-FILE if necessary."
+(define (test-system test-systems directory)
+  "Use a lisp implementation to test the TEST-SYSTEMS using asdf."
   (lisp-eval-program
    `((require :asdf)
-     ,@(map (lambda (asd-file)
-              `(asdf:load-asd (truename ,asd-file)))
-            asd-files)
-     ,@(if test-asd-file
-           `((asdf:load-asd (truename ,test-asd-file)))
-           ;; Try some likely files.
-           (map (lambda (file)
-                  `(when (uiop:file-exists-p ,file)
-                     (asdf:load-asd (truename ,file))))
-                (list
-                 (string-append system "-tests.asd")
-                 (string-append system "-test.asd")
-                 "tests.asd"
-                 "test.asd")))
-     (asdf:test-system ,system))))
+     (asdf:initialize-source-registry
+      (list :source-registry (list :tree (uiop:ensure-pathname ,directory
+                                                               :truenamize t
+                                                               :ensure-directory t))
+            :inherit-configuration))
+     ,@(map (lambda (system)
+              `(asdf:test-system ,system))
+            test-systems))))
 
 (define (string->lisp-keyword . strings)
   "Return a lisp keyword for the concatenation of STRINGS."
diff --git a/guix/build/qt-utils.scm b/guix/build/qt-utils.scm
index b9c5a76f34..b8ecfedd43 100644
--- a/guix/build/qt-utils.scm
+++ b/guix/build/qt-utils.scm
@@ -3,7 +3,7 @@
 ;;; Copyright © 2019, 2020, 2021 Hartmut Goebel <h.goebel@crazy-compilers.com>
 ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
 ;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org>
-;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2021, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;; Copyright © 2021 Brendan Tildesley <mail@brendan.scot>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -26,10 +26,13 @@
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-71)
   #:export (wrap-qt-program
             wrap-all-qt-programs
             %qt-wrap-excluded-inputs))
 
+(define %default-qt-major-version "5")
+
 (define %qt-wrap-excluded-inputs
   '(list "cmake" "extra-cmake-modules" "qttools"))
 
@@ -37,7 +40,9 @@
 ;; facilities for per-application data directories, such as
 ;; /share/quassel. Thus, we include the output directory even if it doesn't
 ;; contain any of the standard subdirectories.
-(define (variables-for-wrapping base-directories output-directory)
+(define* (variables-for-wrapping base-directories output-directory
+                                 #:key
+                                 (qt-major-version %default-qt-major-version))
 
   (define (collect-sub-dirs base-directories file-type subdirectory selectors)
     ;; Append SUBDIRECTORY and each of BASE-DIRECTORIES, and return the subset
@@ -82,17 +87,20 @@
       "/applications" "/cursors" "/fonts" "/icons" "/glib-2.0/schemas"
       "/mime" "/sounds" "/themes" "/wallpapers")
     '("XDG_CONFIG_DIRS" suffix directory "/etc/xdg")
-    ;; The following variables can be extended by the user, but not
-    ;; overridden, to ensure proper operation.
-    '("QT_PLUGIN_PATH" prefix directory "/lib/qt5/plugins")
-    '("QML2_IMPORT_PATH" prefix directory "/lib/qt5/qml")
+    ;; We wrap exactly to avoid potentially mixing Qt5/Qt6 components, which
+    ;; would cause warnings, perhaps problems.
+    `("QT_PLUGIN_PATH" = directory
+      ,(format #f "/lib/qt~a/plugins" qt-major-version))
+    `("QML2_IMPORT_PATH" = directory
+      ,(format #f "/lib/qt~a/qml" qt-major-version))
     ;; QTWEBENGINEPROCESS_PATH accepts a single value, which makes 'exact the
     ;; most suitable environment variable type for it.
-    '("QTWEBENGINEPROCESS_PATH" = regular
-      "/lib/qt5/libexec/QtWebEngineProcess"))))
+    `("QTWEBENGINEPROCESS_PATH" = regular
+      ,(format #f "/lib/qt~a/libexec/QtWebEngineProcess" qt-major-version)))))
 
 (define* (wrap-qt-program* program #:key sh inputs output-dir
-                           qt-wrap-excluded-inputs)
+                           qt-wrap-excluded-inputs
+                           (qt-major-version %default-qt-major-version))
 
   (define input-directories
     (filter-map
@@ -104,12 +112,14 @@
 
   (let ((vars-to-wrap (variables-for-wrapping
                        (cons output-dir input-directories)
-                       output-dir)))
+                       output-dir
+                       #:qt-major-version qt-major-version)))
     (when (not (null? vars-to-wrap))
       (apply wrap-program program #:sh sh vars-to-wrap))))
 
 (define* (wrap-qt-program program-name #:key (sh (which "bash")) inputs output
-                          (qt-wrap-excluded-inputs %qt-wrap-excluded-inputs))
+                          (qt-wrap-excluded-inputs %qt-wrap-excluded-inputs)
+                          (qt-major-version %default-qt-major-version))
   "Wrap the specified program (which must reside in the OUTPUT's \"/bin\"
 directory) with suitably set environment variables.
 
@@ -118,9 +128,11 @@ is wrapped."
   (wrap-qt-program* (string-append output "/bin/" program-name)
                     #:sh sh
                     #:output-dir output #:inputs inputs
-                    #:qt-wrap-excluded-inputs qt-wrap-excluded-inputs))
+                    #:qt-wrap-excluded-inputs qt-wrap-excluded-inputs
+                    #:qt-major-version qt-major-version))
 
 (define* (wrap-all-qt-programs #:key (sh (which "bash")) inputs outputs
+                               qtbase
                                (qt-wrap-excluded-outputs '())
                                (qt-wrap-excluded-inputs %qt-wrap-excluded-inputs)
                                #:allow-other-keys)
@@ -132,6 +144,15 @@ Wrapping is not applied to outputs whose name is listed in
 QT-WRAP-EXCLUDED-OUTPUTS.  This is useful when an output is known not
 to contain any Qt binaries, and where wrapping would gratuitously
 add a dependency of that output on Qt."
+  (define qt-major-version
+    (if qtbase
+        (let ((_ version (package-name->name+version
+                          (strip-store-file-name qtbase))))
+          (first (string-split version #\.)))
+        ;; Provide a fall-back for build systems not having a #:qtbase
+        ;; argument.
+        %default-qt-major-version))
+
   (define (find-files-to-wrap output-dir)
     (append-map
      (lambda (dir)
@@ -151,7 +172,8 @@ add a dependency of that output on Qt."
         (for-each (cut wrap-qt-program* <>
                        #:sh sh
                        #:output-dir output-dir #:inputs inputs
-                       #:qt-wrap-excluded-inputs qt-wrap-excluded-inputs)
+                       #:qt-wrap-excluded-inputs qt-wrap-excluded-inputs
+                       #:qt-major-version qt-major-version)
                   (find-files-to-wrap output-dir))))))
 
   (for-each handle-output outputs))
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index a7401fd73f..eda487f52e 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -8,6 +8,7 @@
 ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
 ;;; Copyright © 2021 Chris Marusich <cmmarusich@gmail.com>
 ;;; Copyright © 2021 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2022 Oleg Pykhalov <go.wigust@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -49,6 +50,7 @@
             MS_RELATIME
             MS_BIND
             MS_MOVE
+            MS_SHARED
             MS_LAZYTIME
             MNT_FORCE
             MNT_DETACH
@@ -537,6 +539,7 @@ the last argument of `mknod'."
 (define MS_NOATIME         1024)
 (define MS_BIND            4096)
 (define MS_MOVE            8192)
+(define MS_SHARED       1048576)
 (define MS_RELATIME     2097152)
 (define MS_STRICTATIME 16777216)
 (define MS_LAZYTIME    33554432)