mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-11-07 07:26:13 -05:00
Merge branch 'version-1.4.0'
This commit is contained in:
Ludovic Courtès
commit
302a84a593
13 changed files with 107 additions and 111 deletions
|
|
@ -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 @@ (define (set-store-permissions directory)
|
|||
(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))))
|
||||
|
|
|
|||
|
|
@ -116,7 +116,7 @@ (define (newt-run-command . args)
|
|||
(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))
|
||||
|
|
|
|||
|
|
@ -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 @@ (define* (run-external-command-with-line-hooks line-hooks command
|
|||
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 @@ (define (pause)
|
|||
|
||||
(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 @@ (define syslog-port
|
|||
(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 @@ (define installer-log-port
|
|||
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 @@ (define-syntax installer-log-line
|
|||
(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)))))))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
|
|||
|
|
@ -164,9 +164,9 @@ (define-public guix
|
|||
;; 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 @@ (define-public guix
|
|||
(commit commit)))
|
||||
(sha256
|
||||
(base32
|
||||
"1asx4jqjdp56r9m693ikrzxn4vaga846v2j6956xkavyj19x42nh"))
|
||||
"0np4fw5kq882nrkfgsvvwgcxqwvm6bzn3dbdf8p48nr7mfrm3rz9"))
|
||||
(file-name (string-append "guix-" version "-checkout"))))
|
||||
(build-system gnu-build-system)
|
||||
(arguments
|
||||
|
|
|
|||
|
|
@ -75,7 +75,8 @@ (define-public texinfo
|
|||
%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
|
||||
|
|
|
|||
|
|
@ -61,7 +61,8 @@ (define-module (gnu services base)
|
|||
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 @@ (define-record-type* <nscd-configuration> nscd-configuration
|
|||
(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?
|
||||
|
|
|
|||
|
|
@ -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 @@ (define (fail2ban-shepherd-service config)
|
|||
(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)))))
|
||||
#~(invoke #$fail2ban-client #$@args))))
|
||||
|
||||
;; TODO: Add 'reload' action.
|
||||
;; 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)
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
@ -972,9 +972,9 @@ (define target (cond
|
|||
(G_ "~a: unsupported image format") image-format)))))))
|
||||
|
||||
|
||||
;;
|
||||
;; Image detection.
|
||||
;;
|
||||
;;;
|
||||
;;; Image type discovery.
|
||||
;;;
|
||||
|
||||
(define (image-modules)
|
||||
"Return the list of image modules."
|
||||
|
|
|
|||
|
|
@ -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 @@ (define (virtfs-option 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 @@ (define qemu-exec
|
|||
"-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))))
|
||||
|
|
|
|||
|
|
@ -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 @@ (define vm
|
|||
(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 '())))
|
||||
|
||||
|
|
|
|||
|
|
@ -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 @@ (define (dump-and-compute-hash)
|
|||
(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)))
|
||||
|
|
|
|||
|
|
@ -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 @@ (define-module (test-store-deduplication)
|
|||
(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)
|
||||
|
|
|
|||
Loading…
Reference in a new issue