summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--gnu/build/install.scm23
-rw-r--r--gnu/installer/newt.scm2
-rw-r--r--gnu/installer/utils.scm26
-rw-r--r--gnu/packages/package-management.scm8
-rw-r--r--gnu/packages/texinfo.scm3
-rw-r--r--gnu/services/base.scm11
-rw-r--r--gnu/services/security.scm26
-rw-r--r--gnu/system/examples/yggdrasil.tmpl60
-rw-r--r--gnu/system/image.scm6
-rw-r--r--gnu/system/vm.scm27
-rw-r--r--gnu/tests/docker.scm4
-rw-r--r--guix/store/deduplication.scm7
-rw-r--r--tests/store-deduplication.scm17
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)