Merge branch 'version-1.4.0'

13 files changed, 108 insertions, 112 deletions

diff --git a/gnu/build/install.scm b/gnu/build/install.scm
index 33a9616c0d..d4982650c1 100644
--- a/gnu/build/install.scm
+++ b/gnu/build/install.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-2020, 2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
 ;;; Copyright © 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
@@ -282,12 +282,31 @@ disk."
     (mount "/.rw-store" (%store-directory) "" MS_MOVE)
     (rmdir "/.rw-store")))
 
+(define (umount* directory)
+  "Unmount DIRECTORY, but retry a few times upon EBUSY."
+  (let loop ((attempts 5))
+    (catch 'system-error
+      (lambda ()
+        (umount directory))
+      (lambda args
+        (if (and (= EBUSY (system-error-errno args))
+                 (> attempts 0))
+            (begin
+              (sleep 1)
+              (loop (- attempts 1)))
+            (apply throw args))))))
+
 (define (unmount-cow-store target backing-directory)
   "Unmount copy-on-write store."
   (let ((tmp-dir "/remove"))
     (mkdir-p tmp-dir)
     (mount (%store-directory) tmp-dir "" MS_MOVE)
-    (umount tmp-dir)
+
+    ;; We might get EBUSY at this point, possibly because of lingering
+    ;; processes with open file descriptors.  Use 'umount*' to retry upon
+    ;; EBUSY, leaving a bit of time.  See <https://issues.guix.gnu.org/59884>.
+    (umount* tmp-dir)
+
     (rmdir tmp-dir)
     (delete-file-recursively
      (string-append target backing-directory))))
diff --git a/gnu/installer/newt.scm b/gnu/installer/newt.scm
index 798ff53af2..e1c4453168 100644
--- a/gnu/installer/newt.scm
+++ b/gnu/installer/newt.scm
@@ -116,7 +116,7 @@ report it by email to ~a.") uploaded-name %guix-bug-report-address)
   (define command-output "")
   (define (line-accumulator line)
     (set! command-output
-          (string-append/shared command-output line "\n")))
+          (string-append/shared command-output line)))
   (define result (run-external-command-with-line-hooks (list line-accumulator)
                                                        args))
   (define exit-val (status:exit-val result))
diff --git a/gnu/installer/utils.scm b/gnu/installer/utils.scm
index 061493e6a7..6838410166 100644
--- a/gnu/installer/utils.scm
+++ b/gnu/installer/utils.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2018, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
-;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019, 2020, 2022 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -159,7 +159,9 @@ COMMAND will be run in a pseudoterminal.  Returns the integer status value of
 the child process as returned by waitpid."
   (define (handler input)
     (and
-     (and=> (get-line input)
+     ;; Lines for progress bars etc. end in \r; treat is as a line ending so
+     ;; those lines are printed right away.
+     (and=> (read-delimited "\r\n" input 'concat)
             (lambda (line)
               (if (eof-object? line)
                   #f
@@ -186,7 +188,7 @@ in a pseudoterminal."
 
   (installer-log-line "running command ~s" command)
   (define result (run-external-command-with-line-hooks
-                  (list %display-line-hook) command
+                  (list display) command
                   #:tty? tty?))
   (define exit-val (status:exit-val result))
   (define term-sig (status:term-sig result))
@@ -264,7 +266,10 @@ values."
       (or port (%make-void-port "w")))))
 
 (define (%syslog-line-hook line)
-  (format (syslog-port) "installer[~d]: ~a~%" (getpid) line))
+  (let ((line (if (string-suffix? "\r" line)
+                  (string-append (string-drop-right line 1) "\n")
+                  line)))
+    (format (syslog-port) "installer[~d]: ~a" (getpid) line)))
 
 (define-syntax syslog
   (lambda (s)
@@ -293,11 +298,7 @@ values."
       port)))
 
 (define (%installer-log-line-hook line)
-  (format (installer-log-port) "~a~%" line))
-
-(define (%display-line-hook line)
-  (display line)
-  (newline))
+  (display line (installer-log-port)))
 
 (define %default-installer-line-hooks
   (list %syslog-line-hook
@@ -309,9 +310,10 @@ values."
     (syntax-case s ()
       ((_ fmt args ...)
        (string? (syntax->datum #'fmt))
-       #'(let ((formatted (format #f fmt args ...)))
-               (for-each (lambda (f) (f formatted))
-                         %default-installer-line-hooks))))))
+       (with-syntax ((fmt (string-append (syntax->datum #'fmt) "\n")))
+         #'(let ((formatted (format #f fmt args ...)))
+             (for-each (lambda (f) (f formatted))
+                       %default-installer-line-hooks)))))))
 
 
 ;;;
diff --git a/gnu/packages/package-management.scm b/gnu/packages/package-management.scm
index daa83f8d0c..5a09b1fcf8 100644
--- a/gnu/packages/package-management.scm
+++ b/gnu/packages/package-management.scm
@@ -164,9 +164,9 @@
   ;; Latest version of Guix, which may or may not correspond to a release.
   ;; Note: the 'update-guix-package.scm' script expects this definition to
   ;; start precisely like this.
-  (let ((version "1.4.0rc1")
-        (commit "9ccc94afb266428b7feeba805617d31eb8afb23c")
-        (revision 1))
+  (let ((version "1.4.0rc2")
+        (commit "7866294e32f1e758d06fce4e1b1035eca3a7d772")
+        (revision 0))
     (package
       (name "guix")
 
@@ -182,7 +182,7 @@
                       (commit commit)))
                 (sha256
                  (base32
-                  "1asx4jqjdp56r9m693ikrzxn4vaga846v2j6956xkavyj19x42nh"))
+                  "0np4fw5kq882nrkfgsvvwgcxqwvm6bzn3dbdf8p48nr7mfrm3rz9"))
                 (file-name (string-append "guix-" version "-checkout"))))
       (build-system gnu-build-system)
       (arguments
diff --git a/gnu/packages/texinfo.scm b/gnu/packages/texinfo.scm
index 5ecbb1e4cd..1dd6d47fdd 100644
--- a/gnu/packages/texinfo.scm
+++ b/gnu/packages/texinfo.scm
@@ -75,7 +75,8 @@
             %standard-phases)
 
        ;; XXX: Work around <https://issues.guix.gnu.org/59616>.
-       #:tests? ,(not (hurd-target?))))
+       #:tests? ,(and (not (hurd-target?))
+                      (not (%current-target-system)))))
     (inputs (list ncurses perl))
     ;; When cross-compiling, texinfo will build some of its own binaries with
     ;; the native compiler. This means ncurses is needed both in both inputs
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index ba59e46155..4908af8edd 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -61,7 +61,8 @@
                           util-linux xfsprogs))
   #:use-module (gnu packages bash)
   #:use-module ((gnu packages base)
-                #:select (coreutils glibc glibc-utf8-locales tar))
+                #:select (coreutils glibc glibc-utf8-locales tar
+                          canonical-package))
   #:use-module ((gnu packages compression) #:select (gzip))
   #:autoload   (gnu packages guile-xyz) (guile-netlink)
   #:autoload   (gnu packages hurd) (hurd)
@@ -1211,7 +1212,13 @@ the tty to run, among other things."
   (name-services nscd-configuration-name-services ;list of file-like
                  (default '()))
   (glibc      nscd-configuration-glibc            ;file-like
-              (default glibc)))
+              (default (let-system (system target)
+                         ;; Unless we're cross-compiling, arrange to use nscd
+                         ;; from 'glibc-final' instead of pulling in a second
+                         ;; glibc copy.
+                         (if target
+                             glibc
+                             (canonical-package glibc))))))
 
 (define-record-type* <nscd-cache> nscd-cache make-nscd-cache
   nscd-cache?
diff --git a/gnu/services/security.scm b/gnu/services/security.scm
index 15fae7a628..50111455fb 100644
--- a/gnu/services/security.scm
+++ b/gnu/services/security.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2022 muradm <mail@muradm.net>
+;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -351,28 +352,27 @@ provided as a list of file-like objects."))
   (match-record config <fail2ban-configuration>
     (fail2ban run-directory)
     (let* ((fail2ban-server (file-append fail2ban "/bin/fail2ban-server"))
+           (fail2ban-client (file-append fail2ban "/bin/fail2ban-client"))
            (pid-file (in-vicinity run-directory "fail2ban.pid"))
            (socket-file (in-vicinity run-directory "fail2ban.sock"))
            (config-dir (file-append (config->fail2ban-etc-directory config)
                                     "/etc/fail2ban"))
            (fail2ban-action (lambda args
-                              #~(lambda _
-                                  (invoke #$fail2ban-server
-                                          "-c" #$config-dir
-                                          "-p" #$pid-file
-                                          "-s" #$socket-file
-                                          "-b"
-                                          #$@args)))))
-
-      ;; TODO: Add 'reload' action.
+                              #~(invoke #$fail2ban-client #$@args))))
+
+      ;; TODO: Add 'reload' action (see 'fail2ban.service.in' in the source).
       (list (shepherd-service
              (provision '(fail2ban))
              (documentation "Run the fail2ban daemon.")
              (requirement '(user-processes))
-             (modules `((ice-9 match)
-                        ,@%default-modules))
-             (start (fail2ban-action "start"))
-             (stop (fail2ban-action "stop")))))))
+             (start #~(make-forkexec-constructor
+                       (list #$fail2ban-server
+                             "-c" #$config-dir "-s" #$socket-file
+                             "-p" #$pid-file "-xf" "start")
+                       #:pid-file #$pid-file))
+             (stop #~(lambda (_)
+                       #$(fail2ban-action "stop")
+                       #f)))))))                  ;successfully stopped
 
 (define fail2ban-service-type
   (service-type (name 'fail2ban)
diff --git a/gnu/system/examples/yggdrasil.tmpl b/gnu/system/examples/yggdrasil.tmpl
deleted file mode 100644
index 4d34f49b54..0000000000
--- a/gnu/system/examples/yggdrasil.tmpl
+++ /dev/null
@@ -1,60 +0,0 @@
-;; This is an operating system configuration template
-;; for a "bare bones" setup, with no X11 display server.
-
-(use-modules (gnu))
-(use-service-modules networking ssh)
-(use-package-modules admin curl networking screen)
-
-(operating-system
-  (host-name "ruby-guard-5545")
-  (timezone "Europe/Budapest")
-  (locale "en_US.utf8")
-
-  ;; Boot in "legacy" BIOS mode, assuming /dev/sdX is the
-  ;; target hard disk, and "my-root" is the label of the target
-  ;; root file system.
-  (bootloader (bootloader-configuration
-                (bootloader grub-bootloader)
-                (targets '("/dev/sdX"))))
-  (file-systems (cons (file-system
-                        (device (file-system-label "my-root"))
-                        (mount-point "/")
-                        (type "ext4"))
-                      %base-file-systems))
-  (users (cons (user-account
-                (name "alice")
-                (comment "Bob's sister")
-                (group "users")
-                ;; adding her to the yggdrasil group means she can use
-                ;; yggdrasilctl to modify the configuration
-                (supplementary-groups '("wheel" "yggdrasil")))
-               %base-user-accounts))
-
-  ;; Globally-installed packages.
-  (packages (cons* screen curl %base-packages))
-
-  ;; Add services to the baseline: a DHCP client and
-  ;; an SSH server.
-  ;; If you add an /etc/yggdrasil-private.conf, you can log in to ssh
-  ;; using your Yggdrasil IPv6 address from another machine running Yggdrasil.
-  ;; Alternatively, the client can sit behind a router that has Yggdrasil.
-  ;; That file is specifically _not_ handled by Guix, because we don't want its
-  ;; contents to sit in the world-readable /gnu/store.
-  (services
-   (append
-    (list
-     (service dhcp-client-service-type)
-     (service yggdrasil-service-type
-              (yggdrasil-configuration
-               (log-to 'stdout)
-               (log-level 'debug)
-               (autoconf? #f)
-               (json-config
-                ;; choose a few from
-                ;; https://github.com/yggdrasil-network/public-peers
-                '((peers . #("tcp://1.2.3.4:1337"))))
-               (config-file #f)))
-     (service openssh-service-type
-              (openssh-configuration
-               (port-number 2222))))
-    %base-services)))
diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index f07a4a5217..d518a05a51 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -972,9 +972,9 @@ image, depending on IMAGE format."
                 (G_ "~a: unsupported image format") image-format)))))))
 
 
-;;
-;; Image detection.
-;;
+;;;
+;;; Image type discovery.
+;;;
 
 (define (image-modules)
   "Return the list of image modules."
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index c2f7efa966..b7bccd72a4 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016 Christine Lemmer-Webber <cwebber@dustycloud.org>
 ;;; Copyright © 2016, 2017 Leo Famulari <leo@famulari.name>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
@@ -234,8 +234,8 @@ with '-virtfs' options for the host file systems listed in SHARED-FS."
 
      #$@(map virtfs-option shared-fs)
      #$@(if rw-image?
-            #~((format #f "-drive file=~a,if=virtio" #$image))
-            #~((format #f "-drive file=~a,if=virtio,cache=writeback,werror=report,readonly=on"
+            #~((format #f "-drive file=~a,format=qcow2,if=virtio" #$image))
+            #~((format #f "-drive file=~a,format=raw,if=virtio,cache=writeback,werror=report,readonly=on"
                        #$image)))))
 
 (define* (system-qemu-image/shared-store-script os
@@ -303,17 +303,26 @@ useful when FULL-BOOT?  is true."
               "-m " (number->string #$memory-size)
               #$@options))
 
+    (define copy-image
+      ;; Script that "copies" BASE-IMAGE to /tmp.  Make a copy-on-write image,
+      ;; which is much cheaper than actually copying it.
+      (program-file "copy-image"
+                    (with-imported-modules '((guix build utils))
+                      #~(begin
+                          (use-modules (guix build utils))
+                          (unless (file-exists? #$rw-image)
+                            (invoke #+(file-append qemu "/bin/qemu-img")
+                                    "create" "-b" #$base-image
+                                    "-F" "raw" "-f" "qcow2" #$rw-image))))))
+
     (define builder
       #~(call-with-output-file #$output
           (lambda (port)
             (format port "#!~a~%"
                     #+(file-append bash "/bin/sh"))
-            (when (not #$volatile?)
-              (format port "~a~%"
-                      #$(program-file "copy-image"
-                                      #~(unless (file-exists? #$rw-image)
-                                          (copy-file #$base-image #$rw-image)
-                                          (chmod #$rw-image #o640)))))
+            #$@(if volatile?
+                   #~()
+                   #~((format port "~a~%" #+copy-image)))
             (format port "exec ~a \"$@\"~%"
                     (string-join #$qemu-exec " "))
             (chmod port #o555))))
diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm
index 3e780d8a60..4267ff89a8 100644
--- a/gnu/tests/docker.scm
+++ b/gnu/tests/docker.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org>
-;;; Copyright © 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019-2022 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -209,7 +209,7 @@ inside %DOCKER-OS."
     (virtual-machine
      (operating-system os)
      (volatile? #f)
-     (disk-image-size (* 5000 (expt 2 20)))
+     (disk-image-size (* 5500 (expt 2 20)))
      (memory-size 2048)
      (port-forwardings '())))
 
diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm
index ab982e3b3d..acb6ffcc4a 100644
--- a/guix/store/deduplication.scm
+++ b/guix/store/deduplication.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017 Caleb Ristvedt <caleb.ristvedt@cune.org>
-;;; Copyright © 2018-2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018-2022 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -262,7 +262,10 @@ down the road."
       (deduplicate file (dump-and-compute-hash) #:store store)
       (call-with-output-file file
         (lambda (output)
-          (dump-port input output size)))))
+          (if (file-port? input)
+              (sendfile output input size 0)
+              (dump-port input output size
+                         #:buffer-size %deduplication-minimum-size))))))
 
 (define* (copy-file/deduplicate source target
                                 #:key (store (%store-directory)))
diff --git a/tests/store-deduplication.scm b/tests/store-deduplication.scm
index 2950fbc1a3..f1845035d8 100644
--- a/tests/store-deduplication.scm
+++ b/tests/store-deduplication.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018, 2020-2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2020-2022 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -136,6 +136,21 @@
        (cons (apply = (map (compose stat:ino stat) identical))
              (map (compose stat:nlink stat) identical))))))
 
+(test-assert "copy-file/deduplicate, below %deduplication-minimum-size"
+  (call-with-temporary-directory
+   (lambda (store)
+     (let ((source (string-append store "/input")))
+       (call-with-output-file source
+         (lambda (port)
+           (display "Hello!\n" port)))
+       (copy-file/deduplicate source
+                              (string-append store "/a")
+                              #:store store)
+       (and (not (directory-exists? (string-append store "/.links")))
+            (file=? source (string-append store "/a"))
+            (not (= (stat:ino (stat (string-append store "/a")))
+                    (stat:ino (stat source)))))))))
+
 (test-assert "copy-file/deduplicate"
   (call-with-temporary-directory
    (lambda (store)