kreyren/guix-kreyren
1
0
Fork 0
Code Issues 1 Pull Requests 1 Releases Activity

Merge branch 'master' into staging

Browse Source
This commit is contained in:
Marius Bakke 2020-06-08 19:05:56 +02:00
commit dd2d3ed2d3
No known key found for this signature in database
GPG Key ID: A2A06DF2A33A54FA
61 changed files with 1737 additions and 559 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.dir-locals.el
View File

@ -99,6 +99,8 @@
(eval . (put 'with-environment-variables 'scheme-indent-function 1))
(eval . (put 'with-fresh-gnupg-setup 'scheme-indent-function 1))
(eval . (put 'with-paginated-output-port 'scheme-indent-function 1))
;; This notably allows '(' in Paredit to not insert a space when the
;; preceding symbol is one of these.
(eval . (modify-syntax-entry ?~ "'"))

3
Makefile.am
View File

@ -7,7 +7,7 @@
# Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
# Copyright © 2017 Leo Famulari <leo@famulari.name>
# Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
# Copyright © 2017 Jan Nieuwenhuizen <janneke@gnu.org>
# Copyright © 2017, 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
# Copyright © 2017 Arun Isaac <arunisaac@systemreboot.net>
# Copyright © 2018 Nikita <nikita@n0.is>
# Copyright © 2018 Julien Lepiller <julien@lepiller.eu>
@ -348,6 +348,7 @@ AUX_FILES = \
EXAMPLES = \
gnu/system/examples/asus-c201.tmpl \
gnu/system/examples/bare-bones.tmpl \
gnu/system/examples/bare-hurd.tmpl \
gnu/system/examples/beaglebone-black.tmpl \
gnu/system/examples/desktop.tmpl \
gnu/system/examples/lightweight-desktop.tmpl \

90
doc/guix.texi
View File

@ -319,7 +319,9 @@ Services
* Version Control Services:: Providing remote access to Git repositories.
* Game Services:: Game servers.
* PAM Mount Service:: Service to mount volumes when logging in.
* Guix Services:: Services relating specifically to Guix.
* Linux Services:: Services tied to the Linux kernel.
* Hurd Services:: Services specific to a Hurd System.
* Miscellaneous Services:: Other services.
Defining Services
@ -11484,9 +11486,21 @@ configuration (@pxref{Using the Configuration System}).
@table @asis
@item @code{kernel} (default: @code{linux-libre})
The package object of the operating system kernel to use@footnote{Currently
only the Linux-libre kernel is supported. In the future, it will be
possible to use the GNU@tie{}Hurd.}.
The package object of the operating system kernel to
use@footnote{Currently only the Linux-libre kernel is fully supported.
Using GNU@tie{}mach with the GNU@tie{}Hurd is experimental and only
available when building a virtual machine disk image.}.
@cindex hurd
@item @code{hurd} (default: @code{#f})
The package object of the hurd to be started by the kernel. When this
field is set, produce a GNU/Hurd operating system. In that case,
@code{kernel} must also be set to the @code{gnumach} package---the
microkernel the Hurd runs on.
@quotation Warning
This feature is experimental and only supported for disk images.
@end quotation
@item @code{kernel-loadable-modules} (default: '())
A list of objects (usually packages) to collect loadable kernel modules
@ -12587,6 +12601,7 @@ declaration.
* PAM Mount Service:: Service to mount volumes when logging in.
* Guix Services:: Services relating specifically to Guix.
* Linux Services:: Services tied to the Linux kernel.
* Hurd Services:: Services specific for a Hurd System.
* Miscellaneous Services:: Other services.
@end menu
@ -26025,6 +26040,48 @@ parameters, can be done as follow:
@end lisp
@end deffn
@node Hurd Services
@subsection Hurd Services
@defvr {Scheme Variable} hurd-console-service-type
This service starts the fancy @code{VGA} console client on the Hurd.
The service's value is a @code{hurd-console-configuration} record.
@end defvr
@deftp {Data Type} hurd-console-configuration
This is the data type representing the configuration for the
hurd-console-service.
@table @asis
@item @code{hurd} (default: @var{hurd})
The Hurd package to use.
@end table
@end deftp
@defvr {Scheme Variable} hurd-getty-service-type
This service starts a tty using the Hurd @code{getty} program.
The service's value is a @code{hurd-getty-configuration} record.
@end defvr
@deftp {Data Type} hurd-getty-configuration
This is the data type representing the configuration for the
hurd-getty-service.
@table @asis
@item @code{hurd} (default: @var{hurd})
The Hurd package to use.
@item @code{tty}
The name of the console this Getty runs on---e.g., @code{"tty1"}.
@item @code{baud-rate} (default: @code{38400})
An integer specifying the baud rate of the tty.
@end table
@end deftp
@node Miscellaneous Services
@subsection Miscellaneous Services
@ -26973,7 +27030,7 @@ The type of an entry in the bootloader menu.
@item @code{label}
The label to show in the menu---e.g., @code{"GNU"}.
@item @code{linux}
@item @code{linux} (default: @code{#f})
The Linux kernel image to boot, for example:
@lisp
@ -26995,9 +27052,10 @@ field is ignored entirely.
The list of extra Linux kernel command-line arguments---e.g.,
@code{("console=ttyS0")}.
@item @code{initrd}
@item @code{initrd} (default: @code{#f})
A G-Expression or string denoting the file name of the initial RAM disk
to use (@pxref{G-Expressions}).
@item @code{device} (default: @code{#f})
The device where the kernel and initrd are to be found---i.e., for GRUB,
@dfn{root} for this menu entry (@pxref{root,,, grub, GNU GRUB manual}).
@ -27008,6 +27066,28 @@ the bootloader will search the device containing the file specified by
the @code{linux} field (@pxref{search,,, grub, GNU GRUB manual}). It
must @emph{not} be an OS device name such as @file{/dev/sda1}.
@item @code{multiboot-kernel} (default: @code{#f})
The kernel to boot in Multiboot-mode (@pxref{multiboot,,, grub, GNU GRUB
manual}). When this field is set, a Multiboot menu-entry is generated.
For example:
@lisp
(file-append mach "/boot/gnumach")
@end lisp
@item @code{multiboot-arguments} (default: @code{()})
The list of extra command-line arguments for the multiboot-kernel.
@item @code{multiboot-modules} (default: @code{()})
The list of commands for loading Multiboot modules. For example:
@lisp
(list (list (file-append hurd "/hurd/ext2fs.static") "ext2fs"
@dots{})
(list (file-append libc "/lib/ld.so.1") "exec"
@dots{}))
@end lisp
@end table
@end deftp

46
gnu/bootloader.scm
View File

@ -3,6 +3,7 @@
;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@ -33,6 +34,9 @@
menu-entry-linux-arguments
menu-entry-initrd
menu-entry-device-mount-point
menu-entry-multiboot-kernel
menu-entry-multiboot-arguments
menu-entry-multiboot-modules
menu-entry->sexp
sexp->menu-entry
@ -77,22 +81,41 @@
(default #f))
(device-mount-point menu-entry-device-mount-point
(default #f))
(linux menu-entry-linux)
(linux menu-entry-linux
(default #f))
(linux-arguments menu-entry-linux-arguments
(default '())) ; list of string-valued gexps
(initrd menu-entry-initrd)) ; file name of the initrd as a gexp
(initrd menu-entry-initrd ; file name of the initrd as a gexp
(default #f))
(multiboot-kernel menu-entry-multiboot-kernel
(default #f))
(multiboot-arguments menu-entry-multiboot-arguments
(default '())) ; list of string-valued gexps
(multiboot-modules menu-entry-multiboot-modules
(default '()))) ; list of multiboot commands, where
; a command is a list of <string>
(define (menu-entry->sexp entry)
"Return ENTRY serialized as an sexp."
(match entry
(($ <menu-entry> label device mount-point linux linux-arguments initrd)
(($ <menu-entry> label device mount-point linux linux-arguments initrd #f
())
`(menu-entry (version 0)
(label ,label)
(device ,device)
(device-mount-point ,mount-point)
(linux ,linux)
(linux-arguments ,linux-arguments)
(initrd ,initrd)))))
(initrd ,initrd)))
(($ <menu-entry> label device mount-point #f () #f
multiboot-kernel multiboot-arguments multiboot-modules)
`(menu-entry (version 0)
(label ,label)
(device ,device)
(device-mount-point ,mount-point)
(multiboot-kernel ,multiboot-kernel)
(multiboot-arguments ,multiboot-arguments)
(multiboot-modules ,multiboot-modules)))))
(define (sexp->menu-entry sexp)
"Turn SEXP, an sexp as returned by 'menu-entry->sexp', into a <menu-entry>
@ -109,7 +132,20 @@ record."
(device-mount-point mount-point)
(linux linux)
(linux-arguments linux-arguments)
(initrd initrd)))))
(initrd initrd)))
(('menu-entry ('version 0)
('label label) ('device device)
('device-mount-point mount-point)
('multiboot-kernel multiboot-kernel)
('multiboot-arguments multiboot-arguments)
('multiboot-modules multiboot-modules) _ ...)
(menu-entry
(label label)
(device device)
(device-mount-point mount-point)
(multiboot-kernel multiboot-kernel)
(multiboot-arguments multiboot-arguments)
(multiboot-modules multiboot-modules)))))
;;;

76
gnu/bootloader/grub.scm
View File

@ -330,36 +330,58 @@ when booting a root file system on a Btrfs subvolume."
(define all-entries
(append entries (bootloader-configuration-menu-entries config)))
(define (menu-entry->gexp entry)
(let* ((device (menu-entry-device entry))
(device-mount-point (menu-entry-device-mount-point entry))
(label (menu-entry-label entry))
(arguments (menu-entry-linux-arguments entry))
(kernel (normalize-file (menu-entry-linux entry)
device-mount-point
store-directory-prefix))
(initrd (normalize-file (menu-entry-initrd entry)
device-mount-point
store-directory-prefix)))
;; Here DEVICE is the store and DEVICE-MOUNT-POINT is its mount point.
;; Use the right file names for KERNEL and INITRD in case
;; DEVICE-MOUNT-POINT is not "/", meaning that the store is on a
;; separate partition.
#~(format port "menuentry ~s {
(let ((label (menu-entry-label entry))
(linux (menu-entry-linux entry))
(device (menu-entry-device entry))
(device-mount-point (menu-entry-device-mount-point entry)))
(if linux
(let ((arguments (menu-entry-linux-arguments entry))
(linux (normalize-file linux
device-mount-point
store-directory-prefix))
(initrd (normalize-file (menu-entry-initrd entry)
device-mount-point
store-directory-prefix)))
;; Here DEVICE is the store and DEVICE-MOUNT-POINT is its mount point.
;; Use the right file names for LINUX and INITRD in case
;; DEVICE-MOUNT-POINT is not "/", meaning that the store is on a
;; separate partition.
;; When BTRFS-SUBVOLUME-FILE-NAME is defined, prepend it the linux and
;; initrd paths, to allow booting from a Btrfs subvolume.
#~(format port "menuentry ~s {
~a
linux ~a ~a
initrd ~a
}~%"
#$label
#$(grub-root-search device kernel)
#$kernel (string-join (list #$@arguments))
#$initrd)))
(define sugar
(eye-candy config
(menu-entry-device (first all-entries))
(menu-entry-device-mount-point (first all-entries))
#:store-directory-prefix store-directory-prefix
#:system system
#:port #~port))
#$label
#$(grub-root-search device linux)
#$linux (string-join (list #$@arguments))
#$initrd))
(let ((kernel (menu-entry-multiboot-kernel entry))
(arguments (menu-entry-multiboot-arguments entry))
(modules (menu-entry-multiboot-modules entry))
(root-index 1)) ; XXX EFI will need root-index 2
#~(format port "
menuentry ~s {
multiboot ~a root=device:hd0s~a~a~a
}~%"
#$label
#$kernel
#$root-index (string-join (list #$@arguments) " " 'prefix)
(string-join (map string-join '#$modules)
"\n module " 'prefix))))))
(define (sugar)
(let* ((entry (first all-entries))
(device (menu-entry-device entry))
(mount-point (menu-entry-device-mount-point entry)))
(eye-candy config
device
mount-point
#:store-directory-prefix store-directory-prefix
#:system system
#:port #~port)))
(define keyboard-layout-config
(let* ((layout (bootloader-configuration-keyboard-layout config))
@ -384,7 +406,7 @@ keymap ~a~%" #$keymap))))
"# This file was generated from your Guix configuration. Any changes
# will be lost upon reconfiguration.
")
#$sugar
#$(sugar)
#$keyboard-layout-config
(format port "
set default=~a

4
gnu/build/activation.scm
View File

@ -320,7 +320,9 @@ improvement."
(define (boot-time-system)
"Return the '--system' argument passed on the kernel command line."
(find-long-option "--system" (linux-command-line)))
(find-long-option "--system" (if (string-contains %host-type "linux-gnu")
linux-command-line
(command-line))))
(define* (activate-current-system
#:optional (system (or (getenv "GUIX_NEW_SYSTEM")

205
gnu/build/hurd-boot.scm Normal file
View File

@ -0,0 +1,205 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu build hurd-boot)
#:use-module (system repl error-handling)
#:autoload (system repl repl) (start-repl)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:use-module (guix build utils)
#:use-module ((guix build syscalls)
#:hide (file-system-type))
#:export (make-hurd-device-nodes
boot-hurd-system))
;;; Commentary:
;;;
;;; Utility procedures useful to boot a Hurd system.
;;;
;;; Code:
;; XXX FIXME c&p from linux-boot.scm
(define (find-long-option option arguments)
"Find OPTION among ARGUMENTS, where OPTION is something like \"--load\".
Return the value associated with OPTION, or #f on failure."
(let ((opt (string-append option "=")))
(and=> (find (cut string-prefix? opt <>)
arguments)
(lambda (arg)
(substring arg (+ 1 (string-index arg #\=)))))))
;; XXX FIXME c&p from guix/utils.scm
(define (readlink* file)
"Call 'readlink' until the result is not a symlink."
(define %max-symlink-depth 50)
(let loop ((file file)
(depth 0))
(define (absolute target)
(if (absolute-file-name? target)
target
(string-append (dirname file) "/" target)))
(if (>= depth %max-symlink-depth)
file
(call-with-values
(lambda ()
(catch 'system-error
(lambda ()
(values #t (readlink file)))
(lambda args
(let ((errno (system-error-errno args)))
(if (or (= errno EINVAL))
(values #f file)
(apply throw args))))))
(lambda (success? target)
(if success?
(loop (absolute target) (+ depth 1))
file))))))
(define* (make-hurd-device-nodes #:optional (root "/"))
"Make some of the nodes needed on GNU/Hurd."
(define (scope dir)
(string-append root (if (string-suffix? "/" root) "" "/") dir))
(mkdir (scope "dev"))
(for-each (lambda (file)
(call-with-output-file (scope file)
(lambda (port)
(display file port) ;avoid hard-linking
(chmod port #o666))))
'("dev/null"
"dev/zero"
"dev/full"
"dev/random"
"dev/urandom"))
;; Don't create /dev/console, /dev/vcs, etc.: they are created by
;; console-run on first boot.
(mkdir (scope "servers"))
(for-each (lambda (file)
(call-with-output-file (scope (string-append "servers/" file))
(lambda (port)
(display file port) ;avoid hard-linking
(chmod port #o444))))
'("startup"
"exec"
"proc"
"password"
"default-pager"
"crash-dump-core"
"kill"
"suspend"))
(mkdir (scope "servers/socket"))
;; Don't create /servers/socket/1 & co: runsystem does that on first boot.
;; TODO: Set the 'gnu.translator' extended attribute for passive translator
;; settings?
)
(define* (boot-hurd-system #:key (on-error 'debug))
"This procedure is meant to be called from an early RC script.
Install the relevant passive translators on the first boot. Then, run system
activation by using the kernel command-line options '--system' and '--load';
starting the Shepherd.
XXX TODO: see linux-boot.scm:boot-system.
XXX TODO: add proper file-system checking, mounting
XXX TODO: move bits to (new?) (hurd?) (activation?) services
XXX TODO: use settrans/setxattr instead of MAKEDEV
"
(define translators
'(("/servers/crash-dump-core" ("/hurd/crash" "--dump-core"))
("/servers/crash-kill" ("/hurd/crash" "--kill"))
("/servers/crash-suspend" ("/hurd/crash" "--suspend"))
("/servers/password" ("/hurd/password"))
("/servers/socket/1" ("/hurd/pflocal"))
("/servers/socket/2" ("/hurd/pfinet" "--interface" "eth0"
"--address" "10.0.2.15" ;the default QEMU guest IP
"--netmask" "255.255.255.0"
"--gateway" "10.0.2.2"
"--ipv6" "/servers/socket/16"))))
(display "Welcome, this is GNU's early boot Guile.\n")
(display "Use '--repl' for an initrd REPL.\n\n")
(call-with-error-handling
(lambda ()
(define (translated? node)
;; Return true if a translator is installed on NODE.
(with-output-to-port (%make-void-port "w")
(lambda ()
(with-error-to-port (%make-void-port "w")
(lambda ()
(zero? (system* "showtrans" "--silent" node)))))))
(let* ((args (command-line))
(system (find-long-option "--system" args))
(to-load (find-long-option "--load" args)))
(format #t "Creating essential servers...\n")
(setenv "PATH" (string-append system "/profile/bin"
":" system "/profile/sbin"))
(for-each (match-lambda
((node command)
(unless (translated? node)
(mkdir-p (dirname node))
(apply invoke "settrans" "--create" node command))))
translators)
(format #t "Creating essential device nodes...\n")
(with-directory-excursion "/dev"
(invoke "MAKEDEV" "--devdir=/dev" "std")
(invoke "MAKEDEV" "--devdir=/dev" "vcs")
(invoke "MAKEDEV" "--devdir=/dev" "tty1""tty2" "tty3" "tty4" "tty5" "tty6")
(invoke "MAKEDEV" "--devdir=/dev" "ptyp0" "ptyp1" "ptyp2")
(invoke "MAKEDEV" "--devdir=/dev" "console"))
(false-if-exception (delete-file "/hurd"))
(let ((hurd/hurd (readlink* (string-append system "/profile/hurd"))))
(symlink hurd/hurd "/hurd"))
(format #t "Starting pager...\n")
(unless (zero? (system* "/hurd/mach-defpager"))
(format #t "FAILED...Good luck!\n"))
(cond ((member "--repl" args)
(format #t "Starting repl...\n")
(start-repl))
(to-load
(format #t "loading '~a'...\n" to-load)
(primitive-load to-load)
(format (current-error-port)
"boot program '~a' terminated, rebooting~%"
to-load)
(sleep 2)
(reboot))
(else
(display "no boot file passed via '--load'\n")
(display "entering a warm and cozy REPL\n")
(start-repl)))))
#:on-error on-error))
;;; hurd-boot.scm ends here

5
gnu/build/image.scm
View File

@ -161,6 +161,8 @@ deduplicates files common to CLOSURE and the rest of PREFIX."
references-graphs
(register-closures? #t)
system-directory
(make-device-nodes
make-essential-device-nodes)
#:allow-other-keys)
"Initialize the given ROOT directory. Use BOOTCFG and BOOTCFG-LOCATION to
install the bootloader configuration.
@ -172,6 +174,9 @@ of the directory of the 'system' derivation."
(populate-root-file-system system-directory root)
(populate-store references-graphs root)
;; Populate /dev.
(make-device-nodes root)
(when register-closures?
(for-each (lambda (closure)
(register-closure root

33
gnu/build/linux-boot.scm
View File

@ -40,7 +40,6 @@
find-long-option
find-long-options
make-essential-device-nodes
make-hurd-device-nodes
make-static-device-nodes
configure-qemu-networking
@ -324,36 +323,6 @@ one specific hardware device. These we have to create."
;; File systems in user space (FUSE).
(mknod (scope "dev/fuse") 'char-special #o666 (device-number 10 229)))
(define* (make-hurd-device-nodes #:optional (root "/"))
"Make some of the nodes needed on GNU/Hurd."
(define (scope dir)
(string-append root
(if (string-suffix? "/" root)
""
"/")
dir))
(mkdir (scope "dev"))
(for-each (lambda (file)
(call-with-output-file (scope file)
(lambda (port)
(chmod port #o666))))
'("dev/null"
"dev/zero"
"dev/full"
"dev/random"
"dev/urandom"))
;; Don't create /dev/console, /dev/vcs, etc.: they are created by
;; console-run on first boot.
(mkdir (scope "servers"))
(mkdir (scope "servers/socket"))
;; Don't create /servers/socket/1 & co: runsystem does that on first boot.
;; TODO: Set the 'gnu.translator' extended attribute for passive translator
;; settings?
)
(define %host-qemu-ipv4-address
(inet-pton AF_INET "10.0.2.10"))
@ -595,4 +564,4 @@ upon error."
(start-repl)))))
#:on-error on-error))
;;; linux-initrd.scm ends here
;;; linux-boot.scm ends here

11
gnu/build/vm.scm
View File

@ -84,8 +84,6 @@
linux initrd
make-disk-image?
single-file-output?
target-arm32?
target-aarch64?
(disk-image-size (* 100 (expt 2 20)))
(disk-image-format "qcow2")
(references-graphs '()))
@ -101,7 +99,14 @@ access it via /dev/hda.
REFERENCES-GRAPHS can specify a list of reference-graph files as produced by
the #:references-graphs parameter of 'derivation'."
(define target-arm? (or target-arm32? target-aarch64?))
(define target-arm32?
(string-prefix? "arm-" %host-type))
(define target-aarch64?
(string-prefix? "aarch64-" %host-type))
(define target-arm?
(or target-arm32? target-aarch64?))
(define arch-specific-flags
`(;; On ARM, a machine has to be specified. Use "virt" machine to avoid

3
gnu/local.mk
View File

@ -582,6 +582,7 @@ GNU_SYSTEM_MODULES = \
%D%/services/games.scm \
%D%/services/getmail.scm \
%D%/services/guix.scm \
%D%/services/hurd.scm \
%D%/services/kerberos.scm \
%D%/services/linux.scm \
%D%/services/lirc.scm \
@ -637,6 +638,7 @@ GNU_SYSTEM_MODULES = \
%D%/build/cross-toolchain.scm \
%D%/build/image.scm \
%D%/build/file-systems.scm \
%D%/build/hurd-boot.scm \
%D%/build/install.scm \
%D%/build/linux-boot.scm \
%D%/build/linux-container.scm \
@ -1083,6 +1085,7 @@ dist_patch_DATA = \
%D%/packages/patches/http-parser-fix-assertion-on-armhf.patch \
%D%/packages/patches/hubbub-sort-entities.patch \
%D%/packages/patches/hurd-cross.patch \
%D%/packages/patches/hurd-xattr.patch \
%D%/packages/patches/hplip-remove-imageprocessor.patch \
%D%/packages/patches/hydra-disable-darcs-test.patch \
%D%/packages/patches/icecat-makeicecat.patch \

24
gnu/packages/admin.scm
View File

@ -1375,6 +1375,7 @@ system administrator.")
(delete-file-recursively "lib/zlib")
#t))))
(build-system gnu-build-system)
(outputs (list "out" "python"))
(arguments
`(#:configure-flags
(list (string-append "--docdir=" (assoc-ref %outputs "out")
@ -1432,7 +1433,22 @@ system administrator.")
(substitute* "plugins/sudoers/Makefile.in"
(("^pre-install:" match)
(string-append match "\ndisabled-" match)))
#t)))
#t))
(add-after 'install 'separate-python-output
(lambda* (#:key target outputs #:allow-other-keys)
(let ((out (assoc-ref outputs "out"))
(out:python (assoc-ref outputs "python")))
(if target
(mkdir-p (string-append out:python "/empty"))
(for-each
(lambda (file)
(let ((old (string-append out "/" file))
(new (string-append out:python "/" file)))
(mkdir-p (dirname new))
(rename-file old new)))
(list "libexec/sudo/python_plugin.so"
"libexec/sudo/python_plugin.la")))
#t))))
;; XXX: The 'testsudoers' test series expects user 'root' to exist, but
;; the chroot's /etc/passwd doesn't have it. Turn off the tests.
@ -2743,13 +2759,13 @@ a new command using the matched rule, and runs it.")
(define-public di
(package
(name "di")
(version "4.47.3")
(version "4.48")
(source
(origin
(method url-fetch)
(uri (string-append "https://gentoo.com/di/di-" version ".tar.gz"))
(sha256
(base32 "0m4npba50sf5s61g5z3xd2r7937zwja941f2h3f081xi24c2hfck"))))
(base32 "0crvvfsxh8ryc0j19a2x52i9zacvggm8zi6j3kzygkcwnpz4km8r"))))
(build-system gnu-build-system)
(arguments
`(#:tests? #f ; obscure test failures
@ -2758,7 +2774,7 @@ a new command using the matched rule, and runs it.")
(delete 'configure) ; no configure script
(add-before 'build 'setup-environment
(lambda* (#:key outputs #:allow-other-keys)
(setenv "CC" "gcc")
(setenv "CC" ,(cc-for-target))
(setenv "prefix" (assoc-ref outputs "out"))
#t)))
#:make-flags (list "--environment-overrides")))

4
gnu/packages/backup.scm
View File

@ -1066,14 +1066,14 @@ interractive mode.")
(define-public burp
(package
(name "burp")
(version "2.3.26")
(version "2.3.28")
(source (origin
(method url-fetch)
(uri (string-append "mirror://sourceforge/burp/burp-" version
"/burp-" version ".tar.bz2"))
(sha256
(base32
"1kwm8wwmzla02cqacgpmac6n5466dqd5czx83lkbp97rmg9017h8"))))
"18f8cjsb87skabvz4cl5pdln35qmim7x686js1xzpld6wyl9kv2k"))))
(build-system gnu-build-system)
(arguments
`(#:phases

6
gnu/packages/docker.scm
View File

@ -47,7 +47,7 @@
#:use-module (gnu packages version-control)
#:use-module (gnu packages virtualization))
(define %docker-version "19.03.9")
(define %docker-version "19.03.11")
(define-public python-docker-py
(package
@ -314,7 +314,7 @@ built-in registry server of Docker.")
(commit (string-append "v" version))))
(file-name (git-file-name name version))
(sha256
(base32 "1a9hkprkix5d7lqi88r8svvfpzh1qbzw9nrkp11lxrcf9wdan4hg"))
(base32 "1pmbggxbazipl24hxiaccbj32379zv79xba76l78v5131ihx922h"))
(patches
(search-patches "docker-fix-tests.patch"))))
(build-system gnu-build-system)
@ -592,7 +592,7 @@ provisioning etc.")
(commit (string-append "v" version))))
(file-name (git-file-name name version))
(sha256
(base32 "1599ff7699p3m925rdyfg7gl3cga6gy0lli7qh2ybyiw2kwf4gj9"))))
(base32 "1y9ymv70r1hndblr64h19q34arxl2f3dqqi2qcrai5zfimcml6lr"))))
(build-system go-build-system)
(arguments
`(#:import-path "github.com/docker/cli"

5
gnu/packages/education.scm
View File

@ -648,15 +648,14 @@ hours.")
(define-public klavaro
(package
(name "klavaro")
(version "3.09")
(version "3.10")
(source
(origin
(method url-fetch)
(uri (string-append "mirror://sourceforge/klavaro/klavaro-"
version ".tar.bz2"))
(sha256
(base32
"12gml7h45b1w9s318h0d5wxw92h7pgajn2kh57j0ak9saq0yb0wr"))))
(base32 "0jnzdrndiq6m0bwgid977z5ghp4q61clwdlzfpx4fd2ml5x3iq95"))))
(build-system gnu-build-system)
(native-inputs
`(("intltool" ,intltool)

81
gnu/packages/emacs-xyz.scm
View File

@ -984,6 +984,31 @@ different tools. It highlights errors and warnings inline in the buffer, and
provides an optional IDE-like error list.")
(license license:gpl3+)))) ;+GFDLv1.3+ for the manual
(define-public emacs-flymake-shellcheck
;; No tag, version grabbed from source .el file.
(let ((commit "78956f0e5bb9c4d35989657a55929e8e3f5691e6")
(revision "0"))
(package
(name "emacs-flymake-shellcheck")
(version (git-version "0.1" revision commit))
(source
(origin
(method git-fetch)
(uri (git-reference
(url "https://github.com/federicotdn/flymake-shellcheck.git")
(commit commit)))
(file-name (git-file-name name version))
(sha256
(base32 "068mx5p4drwgppy4ry1rfq6qi79w6d82b4rnpl2jm37grsg94lix"))))
(build-system emacs-build-system)
(home-page "https://github.com/federicotdn/flymake-shellcheck")
(synopsis "Flymake backend for Bash/Sh powered by ShellCheck")
(description
"This package provides a backend for Flymake to use the
tool ShellCheck for static analyzing @command{bash} and @command{sh}
scripts.")
(license license:gpl3+))))
(define-public emacs-a
(package
(name "emacs-a")
@ -6010,22 +6035,35 @@ after buffer changes.")
`(#:tests? #t
#:phases
(modify-phases %standard-phases
(add-after 'unpack 'fix-realgud:run-process-void-error
;; See: https://github.com/realgud/realgud/issues/269.
(lambda _
(substitute* '("realgud/debugger/gdb/gdb.el"
"realgud/debugger/gub/gub.el")
(("^\\(require 'load-relative\\).*" anchor)
(string-append anchor
"(require-relative-list \
'(\"../../common/run\") \"realgud:\")\n")))
#t))
(add-after 'unpack 'fix-autogen-script
(lambda _
(substitute* "autogen.sh"
(("./configure") "sh configure"))))
(("./configure") "sh configure"))
#t))
(add-after 'fix-autogen-script 'autogen
(lambda _
(setenv "CONFIG_SHELL" "sh")
(invoke "sh" "autogen.sh")))
(add-after 'fix-autogen-script 'set-home
(lambda _
(setenv "HOME" (getenv "TMPDIR"))))
(setenv "HOME" (getenv "TMPDIR"))
#t))
(add-before 'patch-el-files 'remove-realgud-pkg.el
(lambda _
;; FIXME: `patch-el-files' crashes on this file with error:
;; unable to locate "bashdb".
(delete-file "./test/test-regexp-bashdb.el"))))
(delete-file "./test/test-regexp-bashdb.el")
#t)))
#:include (cons* ".*\\.el$" %default-include)))
(native-inputs
`(("autoconf" ,autoconf)
@ -6477,8 +6515,8 @@ S-expression.")
(license license:gpl3+)))
(define-public emacs-lispyville
(let ((commit "d28b937f0cabd8ce61e2020fe9a733ca80d82c74")
(revision "1"))
(let ((commit "1bf38088c981f5ab4ef2e2684952ab6af96378db")
(revision "2"))
(package
(name "emacs-lispyville")
(version (git-version "0.1" revision commit))
@ -6488,31 +6526,12 @@ S-expression.")
(uri (git-reference (url home-page) (commit commit)))
(sha256
(base32
"0f6srwj1qqkfkbmp5n5pjvi6gm7b7xav05p5hrs2i83rjrakzzqx"))
"07z8qqvaxf963kwn7l2gk47989zb7r3d8ybqjs2cg6hzmzb77wbw"))
(file-name (git-file-name name version))))
(propagated-inputs
`(("emacs-evil" ,emacs-evil)
("emacs-lispy" ,emacs-lispy)))
(build-system emacs-build-system)
(arguments
`(#:phases
;; XXX: mysterious whitespace issue with one test
(modify-phases %standard-phases
(add-before 'check 'make-test-writable
(lambda _
(make-file-writable "lispyville-test.el")
#t))
(add-after 'make-test-writable 'remove-test
(lambda _
(emacs-batch-edit-file "lispyville-test.el"
`(progn (progn (goto-char (point-min))
(re-search-forward
"ert-deftest lispyville-comment-and-clone-dwim")
(beginning-of-line)
(kill-sexp))
(basic-save-buffer))))))
#:tests? #t
#:test-command '("make" "test")))
(synopsis "Minor mode for integrating Evil with lispy")
(description
"LispyVille's main purpose is to provide a Lisp editing environment
@ -8273,11 +8292,11 @@ using package inferred style.")
(license license:gpl3+))))
(define-public emacs-lua-mode
(let ((commit "1f596a93b3f1caadd7bba01030f8c179b029600b")
(revision "1"))
(let ((commit "35b6e4c20b8b4eaf783ccc8e613d0dd06dbd165c")
(revision "0"))
(package
(name "emacs-lua-mode")
(version (git-version "20191204" revision commit))
(version (git-version "20200508" revision commit))
(home-page "https://github.com/immerrr/lua-mode/")
(source (origin
(method git-fetch)
@ -8287,14 +8306,14 @@ using package inferred style.")
(file-name (git-file-name name version))
(sha256
(base32
"0i4adlaik3qjx1wkb7rwk2clvj7ci2g8pm0siyb3yk90r6z5mspi"))))
"1hai6rqjm5py0bp57nhggmj9qigwdj3a46ngacpnjc1qmy9kkgfk"))))
(build-system emacs-build-system)
(arguments
`(#:tests? #t
#:test-command '("buttercup" "-l" "lua-mode.el")))
#:test-command '("buttercup" "-l" "lua-mode.el")))
(native-inputs
`(("emacs-buttercup" ,emacs-buttercup)
("lua" ,lua)))
("lua" ,lua)))
(synopsis "Major mode for lua")
(description
"This Emacs package provides a mode for @uref{https://www.lua.org/,

40
gnu/packages/enlightenment.scm
View File

@ -33,6 +33,7 @@
#:use-module (gnu packages algebra)
#:use-module (gnu packages avahi)
#:use-module (gnu packages bash)
#:use-module (gnu packages bittorrent)
#:use-module (gnu packages check)
#:use-module (gnu packages code)
#:use-module (gnu packages compression)
@ -598,3 +599,42 @@ directories.
"This is a process monitor and system monitor using the
@dfn{Enlightenment Foundation Libraries} (EFL).")
(license license:bsd-2)))
(define-public epour
(package
(name "epour")
(version "0.7.0")
(source
(origin
(method url-fetch)
(uri (string-append "https://download.enlightenment.org/rel/apps/epour"
"/epour-" version ".tar.xz"))
(sha256
(base32
"0g9f9p01hsq6dcf4cs1pwq95g6fpkyjgwqlvdjk1km1i5gj5ygqw"))))
(build-system python-build-system)
(arguments
`(#:tests? #f ; no test target
#:use-setuptools? #f
#:phases
(modify-phases %standard-phases
(add-after 'unpack 'find-theme-dir
(lambda* (#:key outputs #:allow-other-keys)
(let ((out (assoc-ref outputs "out")))
(substitute* "epour/gui/__init__.py"
(("join\\(data_path")
(string-append "join(\"" out "/share/epour\"")))
#t))))))
(native-inputs
`(("intltool" ,intltool)
("python-distutils-extra" ,python-distutils-extra)))
(inputs
`(("libtorrent-rasterbar" ,libtorrent-rasterbar)
("python-dbus" ,python-dbus)
("python-efl" ,python-efl)
("python-pyxdg" ,python-pyxdg)))
(home-page "https://www.enlightenment.org")
(synopsis "EFL Bittorrent client")
(description "Epour is a BitTorrent client based on the @dfn{Enlightenment
Foundation Libraries} (EFL) and rb-libtorrent.")
(license license:gpl3+)))

6
gnu/packages/fonts.scm
View File

@ -310,14 +310,14 @@ The Lato 2.010 family supports more than 100 Latin-based languages, over
(define-public font-liberation
(package
(name "font-liberation")
(version "2.00.5")
(version "2.1.1")
(source
(origin
(method url-fetch)
(uri (string-append "https://github.com/liberationfonts/liberation-fonts/"
"files/2926169/liberation-fonts-ttf-" version ".tar.gz"))
"files/4743886/liberation-fonts-ttf-" version ".tar.gz"))
(sha256
(base32 "0kdjsbf0y716k1kv0i0ixdpvg7b9b8xkcsg6favaxdc7pshg0kzi"))))
(base32 "1jkg8j8jx7ffj13z5ilw7dids99dyypljm1pv06ycmghw1pw3qlf"))))
(build-system font-build-system)
(home-page "https://github.com/liberationfonts")
(synopsis "Fonts compatible with Arial, Times New Roman, and Courier New")

4
gnu/packages/freedesktop.scm
View File

@ -1084,7 +1084,7 @@ which speak the Mobile Interface Broadband Model (MBIM) protocol.")
(define-public libqmi
(package
(name "libqmi")
(version "1.24.12")
(version "1.24.14")
(source (origin
(method url-fetch)
(uri (string-append
@ -1092,7 +1092,7 @@ which speak the Mobile Interface Broadband Model (MBIM) protocol.")
"libqmi-" version ".tar.xz"))
(sha256
(base32
"0scb8a2kh0vnzx6kxanfy2s2slnfppvrwg202rxv30m8p2i92frd"))))
"0zshxqbm9ldybgrzh7pjmwmfjvvvfd0xh8qhgl8xiqdb9ply73r0"))))
(build-system gnu-build-system)
(inputs
`(("libgudev" ,libgudev)))

34
gnu/packages/gnome-xyz.scm
View File

@ -6,6 +6,7 @@
;;; Copyright © 2020 Jack Hill <jackhill@jackhill.us>
;;; Copyright © 2020 Ekaitz Zarraga <ekaitz@elenq.tech>
;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2020 Ryan Prior <rprior@protonmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@ -585,3 +586,36 @@ dark elements. It supports GNOME, Unity, Xfce, and Openbox.")
(description "Papirus is a fork of the icon theme Paper with a lot of new icons
and a few extra features.")
(license license:gpl3))))
(define-public vala-language-server
(package
(name "vala-language-server")
;; Note to maintainer: VLS must be built with a Vala toolchain the same
;; version or newer. Therefore when you update this package you may need
;; to update Vala too.
(version "0.48")
(source (origin
(method git-fetch)
(uri (git-reference
(url "https://github.com/benwaffle/vala-language-server.git")
(commit version)))
(file-name (git-file-name name version))
(sha256
(base32 "0chgfpci247skrvsiq1l8cas8sj2z6z42dlarka3df3qwxmh0if0"))))
(build-system meson-build-system)
(arguments '(#:glib-or-gtk? #t))
(inputs
`(("glib" ,glib)
("json-glib" ,json-glib)
("jsonrpc-glib" ,jsonrpc-glib)
("libgee" ,libgee)
("vala" ,vala-0.48)))
(native-inputs
`(("pkg-config" ,pkg-config)))
(home-page "https://github.com/benwaffle/vala-language-server")
(synopsis "Language server for Vala")
(description "The Vala language server is an implementation of the Vala
language specification for the Language Server Protocol (LSP). This tool is
used in text editing environments to provide a complete and integrated
feature-set for programming Vala effectively.")
(license license:lgpl2.1+)))

13
gnu/packages/gnome.scm
View File

@ -3295,6 +3295,19 @@ requirements and without using a different ABI compared to applications and
libraries written in C.")
(license license:lgpl2.1+)))
(define-public vala-0.48
(package
(inherit vala)
(version "0.48.6")
(source (origin
(method url-fetch)
(uri (string-append "mirror://gnome/sources/vala/"
(version-major+minor version) "/"
"vala-" version ".tar.xz"))
(sha256
(base32
"01wppzgacdmp8dgf8047myz1any2yffmrhgl8kqf1q0c0gnhi3fi"))))))
(define-public vte
(package
(name "vte")

115
gnu/packages/golang.scm
View File

@ -917,29 +917,54 @@ increment versions.")
Go.")
(license license:expat))))
(define-public go-github-com-stretchr-objx
(package
(name "go-github-com-stretchr-objx")
(version "0.2.0")
(source
(origin
(method git-fetch)
(uri (git-reference
(url "https://github.com/stretchr/objx.git")
(commit (string-append "v" version))))
(file-name (git-file-name name version))
(sha256
(base32
"0pcdvakxgddaiwcdj73ra4da05a3q4cgwbpm2w75ycq4kzv8ij8k"))))
(build-system go-build-system)
(arguments
'(#:import-path "github.com/stretchr/objx"))
(home-page "https://github.com/stretchr/objx")
(synopsis "Go package for dealing with maps, slices, JSON and other data")
(description "This package provides a Go library for dealing with maps,
slices, JSON and other data.")
(license license:expat)))
(define-public go-github-com-stretchr-testify
(let ((commit
"b1f989447a57594c728884458a39abf3a73447f7")
(revision "0"))
(package
(name "go-github-com-stretchr-testify")
(version (git-version "1.1.4" revision commit))
(source
(origin
(method git-fetch)
(uri (git-reference
(url "https://github.com/stretchr/testify.git")
(commit commit)))
(file-name (git-file-name name version))
(sha256
(base32
"0p0gkqzh2p8r5g0rxm885ljl7ghih7h7hx9w562imx5ka0vdgixv"))))
(build-system go-build-system)
(arguments
'(#:import-path "github.com/stretchr/testify"))
(home-page "https://github.com/stretchr/testify")
(synopsis "Go helper library for tests and invariant checking")
(description "This package provide many tools for testifying that your
(package
(name "go-github-com-stretchr-testify")
(version "1.5.1")
(source
(origin
(method git-fetch)
(uri (git-reference
(url "https://github.com/stretchr/testify.git")
(commit (string-append "v" version))))
(file-name (git-file-name name version))
(sha256
(base32
"09r89m1wy4cjv2nps1ykp00qjpi0531r07q3s34hr7m6njk4srkl"))))
(build-system go-build-system)
(arguments
'(#:import-path "github.com/stretchr/testify"))
(propagated-inputs
`(("github.com/davecgh/go-spew" ,go-github-com-davecgh-go-spew)
("github.com/pmezard/go-difflib" ,go-github-com-pmezard-go-difflib)
("github.com/stretchr/objx" ,go-github-com-stretchr-objx)
("gopkg.in/yaml.v2" ,go-gopkg-in-yaml-v2)))
(home-page "https://github.com/stretchr/testify")
(synopsis "Go helper library for tests and invariant checking")
(description "This package provide many tools for testifying that your
code will behave as you intend.
Features include:
@ -949,7 +974,7 @@ Features include:
@item HTTP response trapping
@item Testing suite interfaces and functions.
@end itemize")
(license license:expat))))
(license license:expat)))
(define-public go-github-com-tevino-abool
(let ((commit
@ -1908,28 +1933,26 @@ that's a lot faster (and only does simple bandwidth metrics).")
(license license:expat))))
(define-public go-github-com-davecgh-go-spew
(let ((commit "d8f796af33cc11cb798c1aaeb27a4ebc5099927d")
(revision "0"))
(package
(name "go-github-com-davecgh-go-spew")
(version (git-version "0.0.0" revision commit))
(source
(origin
(method git-fetch)
(uri (git-reference
(url "https://github.com/davecgh/go-spew.git")
(commit commit)))
(file-name (git-file-name name version))
(sha256
(base32
"19z27f306fpsrjdvkzd61w1bdazcdbczjyjck177g33iklinhpvx"))))
(build-system go-build-system)
(arguments
'(#:unpack-path "github.com/davecgh/go-spew"
#:import-path "github.com/davecgh/go-spew/spew"))
(home-page "https://github.com/davecgh/go-spew")
(synopsis "Deep pretty printer for Go data structures to aid in debugging")
(description "Package @command{spew} implements a deep pretty printer
(package
(name "go-github-com-davecgh-go-spew")
(version "1.1.1")
(source
(origin
(method git-fetch)
(uri (git-reference
(url "https://github.com/davecgh/go-spew.git")
(commit (string-append "v" version))))
(file-name (git-file-name name version))
(sha256
(base32
"0hka6hmyvp701adzag2g26cxdj47g21x6jz4sc6jjz1mn59d474y"))))
(build-system go-build-system)
(arguments
'(#:unpack-path "github.com/davecgh/go-spew"
#:import-path "github.com/davecgh/go-spew/spew"))
(home-page "https://github.com/davecgh/go-spew")
(synopsis "Deep pretty printer for Go data structures to aid in debugging")
(description "Package @command{spew} implements a deep pretty printer
for Go data structures to aid in debugging.
A quick overview of the additional features spew provides over the built-in printing facilities for Go data types are as follows:
@ -1945,7 +1968,7 @@ pointer receiver are optionally invoked when passing non-pointer variables.
includes offsets, byte values in hex, and ASCII output (only when using Dump
style).
@end itemize\n")
(license license:isc))))
(license license:isc)))
(define-public go-github-com-btcsuite-btclog
(let ((commit "84c8d2346e9fc8c7b947e243b9c24e6df9fd206a")

143
gnu/packages/hurd.scm
View File

@ -31,6 +31,7 @@
#:use-module (guix utils)
#:use-module (guix build-system gnu)
#:use-module (guix build-system trivial)
#:use-module (gnu build hurd-boot)
#:use-module (gnu packages autotools)
#:use-module (gnu packages compression)
#:use-module (gnu packages flex)
@ -309,56 +310,6 @@ Hurd-minimal package which are needed for both glibc and GCC.")
(base32
"0p2vhnc18cnbmb39vq4m7hzv4mhnm2l0a2s7gx3ar277fwng3hys"))))
(define (hurd-rc-script)
"Return a script to be installed as /libexec/rc in the 'hurd' package. The
script takes care of installing the relevant passive translators on the first
boot, since this cannot be done from GNU/Linux."
(define translators
'(("/servers/crash-dump-core" ("/hurd/crash" "--dump-core"))
("/servers/crash-kill" ("/hurd/crash" "--kill"))
("/servers/crash-suspend" ("/hurd/crash" "--suspend"))
("/servers/password" ("/hurd/password"))
("/servers/socket/1" ("/hurd/pflocal"))
("/servers/socket/2" ("/hurd/pfinet" "--interface" "eth0"
"--address" "10.0.2.15" ;the default QEMU guest IP
"--netmask" "255.255.255.0"
"--gateway" "10.0.2.2"
"--ipv6" "/servers/socket/16"))))
(define rc
(with-imported-modules '((guix build utils))
#~(begin
(use-modules (guix build utils)
(ice-9 match))
;; "@HURD@" is a placeholder.
(setenv "PATH" "@HURD@/bin")
(define (translated? node)
;; Return true if a translator is installed on NODE.
(with-output-to-port (%make-void-port "w")
(lambda ()
(with-error-to-port (%make-void-port "w")
(lambda ()
(zero? (system* "showtrans" "-s" node)))))))
(for-each (match-lambda
((node command)
(unless (translated? node)
(mkdir-p (dirname node))
(apply invoke "settrans" "-c" node command))))
'#$translators)
;; Start the oh-so-fancy console client.
(mkdir-p "/var/run") ;for the PID file
(invoke "console" "--daemonize" "-c" "/dev/vcs"
"-d" "vga" "-d" "pc_kbd" "-d" "generic_speaker"))))
;; FIXME: We want the program to use the cross-compiled Guile when
;; cross-compiling. But why do we need to be explicit here?
(with-parameters ((%current-target-system "i586-pc-gnu"))
(program-file "rc" rc)))
(define dde-sources
;; This is the current tip of the dde branch
(let ((commit "ac1c7eb7a8b24b7469bed5365be38a968d59a136"))
@ -377,7 +328,8 @@ boot, since this cannot be done from GNU/Linux."
(name "hurd")
(version (package-version hurd-headers))
(source (origin (inherit (package-source hurd-headers))
(patches (search-patches "hurd-cross.patch"))))
(patches (search-patches "hurd-cross.patch"
"hurd-xattr.patch"))))
(arguments
`(#:phases
(modify-phases %standard-phases
@ -424,6 +376,36 @@ boot, since this cannot be done from GNU/Linux."
(substitute* '("daemons/Makefile" "utils/Makefile")
(("-o root -m 4755") ""))
#t))
(add-after 'unpack 'create-runsystem
(lambda _
;; XXX Work towards having startup.c invoke the Guile rc
(delete-file "daemons/runsystem.sh")
(with-output-to-file "daemons/runsystem.sh"
(lambda _
(display "#! /bin/bash
# XXX Guile needs pipe support for its finalizer thread, to start.
# Remove this script when Linux and the Hurd have xattr patches.
PATH=@PATH@
fsck --yes --force /
fsysopts / --writable
# Note: this /hurd/ gets substituted
settrans --create /servers/socket/1 /hurd/pflocal
# parse multiboot arguments
for i in \"$@\"; do
case $i in
(--system=*)
system=${i#--system=}
;;
esac
done
echo Starting ${system}/rc...
exec ${system}/rc \"$@\"
")))))
(add-before 'build 'set-file-names
(lambda* (#:key inputs outputs #:allow-other-keys)
(let* ((out (assoc-ref outputs "out"))
@ -436,45 +418,39 @@ boot, since this cannot be done from GNU/Linux."
(("/bin/login")
(string-append out "/bin/login"))
(("/bin/bash") (string-append bash "/bin/bash")))
(substitute* '("startup/startup.c" "init/init.c" "config/ttys")
(substitute* '("startup/startup.c" "config/ttys")
(("/libexec/")
(string-append out "/libexec/")))
(substitute* '("utils/uptime.sh")
(("/bin/w")
(string-append out "/bin/w")))
(substitute* "daemons/console-run.c"
;; Upon first boot the /hurd symlink does not exist; it is
;; created during activation: Hard-code the .../hurd store file
;; name.
(substitute* '("boot/boot.c"
"daemons/console-run.c"
"startup/startup.c")
(("/hurd/")
(string-append out "/hurd/")))
(substitute* '("libdiskfs/boot-start.c"
"libdiskfs/opts-std-startup.c")
(("_HURD_STARTUP")
(string-append "\"" out "/hurd/startup\"")))
(substitute* '("daemons/runsystem.sh"
"daemons/runsystem.hurd.sh"
"sutils/MAKEDEV.sh")
"utils/fakeroot.sh"
"utils/remap.sh"
"sutils/MAKEDEV.sh"
"sutils/losetup.sh")
(("^PATH=.*")
(string-append "PATH=" out "/bin:" out "/sbin:"
coreutils "/bin:"
sed "/bin:" grep "/bin:"
util-linux "/bin\n"))
(("^SHELL=.*")
(string-append "SHELL=" bash "/bin/bash\n"))
(string-append "PATH=" out "/bin"
":" out "/sbin"
":" coreutils "/bin"
":" grep "/bin"
":" sed "/bin"
":" util-linux "/sbin\n"))
(("/sbin/") (string-append out "/sbin/"))
(("/libexec/") (string-append out "/libexec/"))
(("/hurd/") (string-append out "/hurd/")))
(substitute* "daemons/runsystem.sh"
(("export PATH")
(string-append "export PATH\n"
"\
fsysopts / --writable
# MAKEDEV relies on pipes so this needs to be set up.
settrans -c /servers/socket/1 /hurd/pflocal
(cd /dev; MAKEDEV -D /dev std vcs tty{1,2,3,4,5,6})\n")))
(substitute* "daemons/runsystem.hurd.sh"
(("export PATH")
"export PATH
fsysopts / --writable\n"))
#t)))
(add-after 'patch-shebangs 'patch-libexec-shebangs
(lambda* (#:key inputs outputs #:allow-other-keys)
@ -505,16 +481,6 @@ fsysopts / --writable\n"))
(mkdir-p datadir)
(copy-file "unifont"
(string-append datadir "/vga-system.bdf"))
#t)))
(add-after 'install 'install-rc-file
(lambda* (#:key inputs outputs #:allow-other-keys)
(let* ((out (assoc-ref outputs "out"))
(file (string-append out "/libexec/rc"))
(rc (assoc-ref inputs "hurd-rc")))
(delete-file file)
(copy-file rc file)
(substitute* file
(("@HURD@") out))
#t))))
#:configure-flags (list (string-append "LDFLAGS=-Wl,-rpath="
%output "/lib")
@ -529,7 +495,6 @@ fsysopts / --writable\n"))
(build-system gnu-build-system)
(inputs
`(("glibc-hurd-headers" ,glibc/hurd-headers)
("hurd-rc" ,(hurd-rc-script))
("libgcrypt" ,libgcrypt) ;for /hurd/random
("libdaemon" ,libdaemon) ;for /bin/console --daemonize

77
gnu/packages/linux.scm
View File

@ -44,6 +44,7 @@
;;; Copyright © 2020 Vincent Legoll <vincent.legoll@gmail.com>
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2020 Brice Waegeneire <brice@waegenei.re>
;;; Copyright © 2020 Morgan Smith <Morgan.J.Smith@outlook.com>
;;;
;;; This file is part of GNU Guix.
;;;
@ -370,26 +371,26 @@ corresponding UPSTREAM-SOURCE (an origin), using the given DEBLOB-SCRIPTS."
(sha256 hash)))
(define-public linux-libre-5.6-version "5.6.16")
(define-public linux-libre-5.6-version "5.6.17")
(define-public linux-libre-5.6-pristine-source
(let ((version linux-libre-5.6-version)
(hash (base32 "1xvwk6yxi5nhiwhskpmr89a31286mw9hpm0y3l3i5ydswx6lnl15")))
(hash (base32 "17kzalz8z6svv6nwa3dbmf7nyvpb2wwwyabj19vdwf6v05a28fn3")))
(make-linux-libre-source version
(%upstream-linux-source version hash)
deblob-scripts-5.6)))
(define-public linux-libre-5.4-version "5.4.44")
(define-public linux-libre-5.4-version "5.4.45")
(define-public linux-libre-5.4-pristine-source
(let ((version linux-libre-5.4-version)
(hash (base32 "0fc4nsv1zwlknvfv1bzkjlq2vlx28wfl09hg2p7r8cn7a77bphlp")))
(hash (base32 "0bpy2lb3bqmkaqxzdmssgmhbjsys7d3lyfv4x919q0596jgh6gqh")))
(make-linux-libre-source version
(%upstream-linux-source version hash)
deblob-scripts-5.4)))
(define-public linux-libre-4.19-version "4.19.126")
(define-public linux-libre-4.19-version "4.19.127")
(define-public linux-libre-4.19-pristine-source
(let ((version linux-libre-4.19-version)
(hash (base32 "129ziwvk3f4xh8jvnq2krajc0bnrl2zxffqsiz63j7p3vc57wakf")))
(hash (base32 "0vsq5vjyh6n8acjnldfs0zny63l12fn2pssb8zbwidc8qmmqibw2")))
(make-linux-libre-source version
(%upstream-linux-source version hash)
deblob-scripts-4.19)))
@ -988,8 +989,8 @@ and should be used with caution, especially on untested models.")
(license license:gpl3+)))) ; see README.md (no licence headers)
(define-public rtl8812au-aircrack-ng-linux-module
(let ((commit "945d6ed6505c32f0993b1dba576388e92e78101b")
(revision "0"))
(let ((commit "df2b8dfd8cb7d9f6cfeb55abaeab8a5372011fc9")
(revision "1"))
(package
(name "rtl8812au-aircrack-ng-linux-module")
(version (git-version "5.6.4.2" revision commit))
@ -1001,7 +1002,7 @@ and should be used with caution, especially on untested models.")
(commit commit)))
(file-name (git-file-name name version))
(sha256
(base32 "1pjws7qb5l4z9k80vgz4zdxmqhbwxjjrmkpf0hijf821byyddvi7"))
(base32 "1qcr0j8yhg8l9l0f5y55zcsk1mgf3qd46yh9xfqgg91szxa3yvca"))
(modules '((guix build utils)))
(snippet
'(begin
@ -1013,15 +1014,15 @@ and should be used with caution, especially on untested models.")
#t))))
(build-system linux-module-build-system)
(arguments
`(#:phases
`(#:make-flags
(list (string-append "KSRC="
(assoc-ref %build-inputs "linux-module-builder")
"/lib/modules/build"))
#:phases
(modify-phases %standard-phases
(replace 'build
(lambda* (#:key inputs make-flags #:allow-other-keys)
(apply invoke "make"
(string-append "KSRC="
(assoc-ref inputs "linux-module-builder")
"/lib/modules/build")
(or make-flags '())))))
(lambda* (#:key (make-flags '()) #:allow-other-keys)
(apply invoke "make" make-flags))))
#:tests? #f)) ; no test suite
(supported-systems '("x86_64-linux" "i686-linux"))
(home-page "https://github.com/aircrack-ng/rtl8812au")
@ -1051,16 +1052,17 @@ RTL8812AU, RTL8821AU, and RTL8814AU chips.")
"17jiw25k74kv5lnvgycvj2g1n06hbrpjz6p4znk4a62g136rhn4s"))))
(build-system linux-module-build-system)
(arguments
`(#:phases
`(#:make-flags
(list "CC=gcc"
(string-append "KSRC="
(assoc-ref %build-inputs "linux-module-builder")
"/lib/modules/build"))
#:phases
(modify-phases %standard-phases
(replace 'build
(lambda* (#:key (make-flags '()) inputs #:allow-other-keys)
(setenv "CC" "gcc")
(invoke "make"
(string-append "KSRC="
(assoc-ref inputs "linux-module-builder")
"/lib/modules/build")))))
#:tests? #f))
(lambda* (#:key (make-flags '()) #:allow-other-keys)
(apply invoke "make" make-flags))))
#:tests? #f)) ; no test suite
(home-page "https://github.com/tomaspinho/rtl8821ce")
(synopsis "Linux driver for Realtek RTL8821CE wireless network adapters")
(description "This is Realtek's RTL8821CE Linux driver for wireless
@ -1135,6 +1137,33 @@ module allows the control of the backlight level or luminance property when
supported under @file{/sys/class/backlight/}.")
(license license:gpl2+)))
(define-public v4l2loopback-linux-module
(package
(name "v4l2loopback-linux-module")
(version "0.12.5")
(source (origin
(method git-fetch)
(uri (git-reference
(url "https://github.com/umlaeute/v4l2loopback.git")
(commit (string-append "v" version))))
(file-name (git-file-name name version))
(sha256
(base32
"1qi4l6yam8nrlmc3zwkrz9vph0xsj1cgmkqci4652mbpbzigg7vn"))))
(build-system linux-module-build-system)
(home-page "https://github.com/umlaeute/v4l2loopback")
(synopsis "Linux kernel module to create virtual V4L2 video devices")
(description
"This Linux module creates virtual video devices. @acronym{V4L2, Video
for Linux 2} applications will treat these as ordinary video devices but read
video data generated by another application, instead of a hardware device such
as a capture card.
This lets you apply nifty effects to your Jitsi video, for example, but also
allows some more serious things like adding streaming capabilities to an
application by hooking GStreamer into the loopback device.")
(license license:gpl2+)))
;;;
;;; Pluggable authentication modules (PAM).

59
gnu/packages/lisp-xyz.scm
View File

@ -3197,6 +3197,17 @@ WebKit browsing engine.")
`(("alexandria" ,sbcl-alexandria)
("bordeaux-threads" ,sbcl-bordeaux-threads)
("trivial-garbage" ,sbcl-trivial-garbage)))
(arguments
`(#:phases
(modify-phases %standard-phases
(add-after 'unpack 'fix-dependency
;; lparallel loads a SBCL specific system in its asd file. This is
;; not carried over into the fasl which is generated. In order for
;; it to be carried over, it needs to be listed as a dependency.
(lambda _
(substitute* "lparallel.asd"
((":depends-on \\(:alexandria" all)
(string-append all " #+sbcl :sb-cltl2"))))))))
(home-page "https://lparallel.org/")
(synopsis "Parallelism for Common Lisp")
(description
@ -11927,3 +11938,51 @@ tables.")
(define-public ecl-cl-ascii-table
(sbcl-package->ecl-package sbcl-cl-ascii-table))
(define-public sbcl-cl-rdkafka
(package
(name "sbcl-cl-rdkafka")
(version "1.0.2")
(source
(origin
(method git-fetch)
(uri (git-reference
(url "https://github.com/SahilKang/cl-rdkafka.git")
(commit (string-append "v" version))))
(file-name (git-file-name name version))
(sha256
(base32
"1qcgfd4h7syilzmrmd4z2vknbvawda3q3ykw7xm8n381syry4g82"))))
(build-system asdf-build-system/sbcl)
(arguments
`(#:tests? #f ; Attempts to connect to locally running Kafka
#:phases
(modify-phases %standard-phases
(add-after 'unpack 'fix-paths
(lambda* (#:key inputs #:allow-other-keys)
(substitute* "src/low-level/librdkafka-bindings.lisp"
(("librdkafka" all)
(string-append (assoc-ref inputs "librdkafka") "/lib/"
all)))))
(add-before 'cleanup 'move-bundle
(lambda* (#:key outputs #:allow-other-keys)
(let* ((out (assoc-ref outputs "out"))
(actual (string-append out "/lib/sbcl/src/cl-rdkafka.fasl"))
(expected (string-append
out "/lib/sbcl/cl-rdkafka--system.fasl")))
(copy-file actual expected)
#t))))))
(inputs
`(("bordeaux-threads" ,sbcl-bordeaux-threads)
("cffi" ,sbcl-cffi)
("cffi-grovel" ,sbcl-cffi-grovel)
("librdkafka" ,librdkafka)
("lparallel" ,sbcl-lparallel)
("trivial-garbage" ,sbcl-trivial-garbage)))
(home-page "https://github.com/SahilKang/cl-rdkafka")
(synopsis "Common Lisp client library for Apache Kafka")
(description "A Common Lisp client library for Apache Kafka.")
(license license:gpl3)))
(define-public cl-rdkafka
(sbcl-package->cl-source-package sbcl-cl-rdkafka))

15
gnu/packages/machine-learning.scm
View File

@ -11,7 +11,7 @@
;;; Copyright © 2018 Julien Lepiller <julien@lepiller.eu>
;;; Copyright © 2018 Björn Höfling <bjoern.hoefling@bjoernhoefling.de>
;;; Copyright © 2019 Nicolas Goaziou <mail@nicolasgoaziou.fr>
;;; Copyright © 2019 Guillaume Le Vaillant <glv@posteo.net>
;;; Copyright © 2019, 2020 Guillaume Le Vaillant <glv@posteo.net>
;;; Copyright © 2019 Brett Gilio <brettg@gnu.org>
;;; Copyright © 2020 Konrad Hinsen <konrad.hinsen@fastmail.net>
;;; Copyright © 2020 Edouard Klein <edk@beaver-labs.com>
@ -2067,18 +2067,7 @@ online linear classification written in Common Lisp.")
("cl-online-learning" ,sbcl-cl-online-learning)
("lparallel" ,sbcl-lparallel)))
(arguments
`(;; The tests download data from the Internet
#:tests? #f
#:phases
(modify-phases %standard-phases
(add-after 'unpack 'add-sb-cltl2-dependency
(lambda _
;; sb-cltl2 is required by lparallel when using sbcl, but it is
;; not loaded automatically.
(substitute* "cl-random-forest.asd"
(("\\(in-package :cl-user\\)")
"(in-package :cl-user) #+sbcl (require :sb-cltl2)"))
#t)))))
`(#:tests? #f)) ; The tests download data from the Internet
(synopsis "Random Forest and Global Refinement for Common Lisp")
(description
"CL-random-forest is an implementation of Random Forest for multiclass

4
gnu/packages/mail.scm
View File

@ -711,7 +711,7 @@ security functionality including PGP, S/MIME, SSH, and SSL.")
(define-public mu
(package
(name "mu")
(version "1.4.8")
(version "1.4.9")
(source (origin
(method url-fetch)
(uri (string-append "https://github.com/djcb/mu/releases/"
@ -719,7 +719,7 @@ security functionality including PGP, S/MIME, SSH, and SSL.")
"mu-" version ".tar.xz"))
(sha256
(base32
"0vww8n7r6pfl4jyijhzas3fpdl6v1ndhc99zr1fsamjldxqpxk5m"))))
"0dgmwdaszh5m7v1py3f9n9f6avb30vrl93g58a1k225iwdsv01d5"))))
(build-system gnu-build-system)
(native-inputs
`(("pkg-config" ,pkg-config)

7
gnu/packages/make-bootstrap.scm
View File

@ -706,7 +706,12 @@ for `sh' in $PATH, and without nscd, and with static NSS modules."
;; When `configure' checks for ltdl availability, it
;; doesn't try to link using libtool, and thus fails
;; because of a missing -ldl. Work around that.
''("LDFLAGS=-ldl"))
;; XXX: On ARMv7, disable JIT: it causes crashes with 3.0.2,
;; possibly related to <https://bugs.gnu.org/40737>.
(if (target-arm32?)
''("LDFLAGS=-ldl" "--disable-jit")
''("LDFLAGS=-ldl")))
((#:phases phases '%standard-phases)
`(modify-phases ,phases

6
gnu/packages/package-management.scm
View File

@ -118,8 +118,8 @@
;; Note: the 'update-guix-package.scm' script expects this definition to
;; start precisely like this.
(let ((version "1.1.0")
(commit "ea924134f819eef072ba7df9080d39de97fd73e6")
(revision 6))
(commit "ab9e30039d9312285ea3f4ed43f81c9c2c0dae08")
(revision 9))
(package
(name "guix")
@ -135,7 +135,7 @@
(commit commit)))
(sha256
(base32
"08likdidf3k1zqf8821h6a84dsrvgbdhridhkzpjymc2c884j0w4"))
"0qb2haf5dyq5x1hcjyx58v455lzi6ffa68ldm0615jy25w5phmxq"))
(file-name (string-append "guix-" version "-checkout"))))
(build-system gnu-build-system)
(arguments

53
gnu/packages/patches/hurd-xattr.patch Normal file
View File

@ -0,0 +1,53 @@
From 75cb948c575fca3962c4cce115d31dd178bc389f Mon Sep 17 00:00:00 2001
From: "Jan (janneke) Nieuwenhuizen" <janneke@gnu.org>
Date: Tue, 12 May 2020 07:39:59 +0200
Subject: [PATCH] ext2fs: Update to upstream Hurd-reserved xattr index for
"gnu.*".
See
https://git.kernel.org/pub/scm/linux/kernel/git/torvalds/linux.git/commit/?id=3980bd3b406addb327d858aebd19e229ea340b9a
This supports setting (and reading) of passive trasnlators from
GNU/Linux, e.g.
dd if=/dev/zero of=file bs=1k count=1000
losetup /dev/loop0 file
mke2fs -t ext2 -o hurd -O ext_attr /dev/loop0
mount -t ext2 -o x-xattr-translator-records /dev/loop0 /mnt
mkdir -p /mnt/servers/socket
touch /mnt/servers/socket/1
setfattr --name=gnu.translator --value='/hurd/pflocal\0' /mnt/servers/socket/1
getfattr --name=gnu.translator /mnt/servers/socket/1
# file: 1
gnu.translator="/hurd/pflocal"
* ext2fs/xattr.c (struct _xattr_prefix): For "gnu.*", use index for
the Hurd (10).
---
ext2fs/xattr.c | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/ext2fs/xattr.c b/ext2fs/xattr.c
index f6ea0f39..78458214 100644
--- a/ext2fs/xattr.c
+++ b/ext2fs/xattr.c
@@ -1,6 +1,6 @@
/* Ext2 support for extended attributes
- Copyright (C) 2006, 2016 Free Software Foundation, Inc.
+ Copyright (C) 2006, 2016, 2020 Free Software Foundation, Inc.
Written by Thadeu Lima de Souza Cascardo <cascardo@dcc.ufmg.br>
and Shengyu Zhang <lastavengers@outlook.com>
@@ -39,7 +39,7 @@ xattr_prefixes[] =
{
1, "user.", sizeof "user." - 1},
{
- 7, "gnu.", sizeof "gnu." - 1},
+ 10, "gnu.", sizeof "gnu." - 1},
{
0, NULL, 0}
};
--
2.26.0

37
gnu/packages/python-web.scm
View File

@ -796,25 +796,30 @@ ebooks, due to cssutils not receiving updates as of 1.0.2.")
(define-public python-cssselect
(package
(name "python-cssselect")
(version "0.9.2")
(source
(origin
(method url-fetch)
(uri (pypi-uri "cssselect" version))
(sha256
(base32
"1xg6gbva1yswghiycmgincv6ab4bn7hpm720ndbj40h8xycmnfvi"))))
(version "1.1.0")
(source (origin
;; The PyPI release does not contain tests.
(method git-fetch)
(uri (git-reference
(url "https://github.com/scrapy/cssselect")
(commit (string-append "v" version))))
(file-name (git-file-name name version))
(sha256
(base32
"0xslrnhbrmgakp4xg6k26qffay3kqffp3a2z2sk27c65rwxa79kc"))))
(build-system python-build-system)
(arguments
;; tests fail with message
;; AttributeError: 'module' object has no attribute 'tests'
`(#:tests? #f))
(home-page
"https://pythonhosted.org/cssselect/")
(synopsis
"CSS3 selector parser and translator to XPath 1.0")
`(#:phases (modify-phases %standard-phases
(replace 'check
(lambda _
(invoke "pytest" "-vv"))))))
(native-inputs
`(("python-lxml" ,python-lxml)
("python-pytest" ,python-pytest)))
(home-page "https://github.com/scrapy/cssselect")
(synopsis "CSS3 selector parser and translator to XPath 1.0")
(description
"Cssselect ia a Python module that parses CSS3 Selectors and translates
"Cssselect ia a Python module that parses CSS3 Selectors and translates
them to XPath 1.0 expressions. Such expressions can be used in lxml or
another XPath engine to find the matching elements in an XML or HTML document.")
(license license:bsd-3)))

72
gnu/packages/python-xyz.scm
View File

@ -1669,38 +1669,30 @@ human-friendly syntax.")
(define-public python2-schedule
(package-with-python2 python-schedule))
(define-public python2-mechanize
(define-public python-mechanize
(package
(name "python2-mechanize")
(version "0.2.5")
(name "python-mechanize")
(version "0.4.5")
(source
(origin
(method url-fetch)
(uri (pypi-uri "mechanize" version))
(sha256
(base32
"0rj7r166i1dyrq0ihm5rijfmvhs8a04im28lv05c0c3v206v4rrf"))))
"1z9kqcwb8gfq2l6i42z624kxpd8692a0c8gw2x5bbm7n848w2mb3"))))
(build-system python-build-system)
(arguments
`(#:python ,python-2 ; apparently incompatible with Python 3
#:tests? #f))
;; test fails with message
;; AttributeError: 'module' object has no attribute 'test_pullparser'
;; (python-3.3.2) or
;; AttributeError: 'module' object has no attribute 'test_urllib2_localnet'
;; (python-2.7.5).
;; The source code is from March 2011 and probably not up-to-date
;; with respect to python unit tests.
(home-page "http://wwwsearch.sourceforge.net/mechanize/")
(propagated-inputs
`(("python-html5lib" ,python-html5lib)))
(home-page "https://github.com/python-mechanize/mechanize")
(synopsis
"Stateful programmatic web browsing in Python")
(description
"Mechanize implements stateful programmatic web browsing in Python,
after Andy Lester’s Perl module WWW::Mechanize.")
(license (license:non-copyleft
"file://COPYING"
"See COPYING in the distribution."))))
(license license:bsd-3)))
(define-public python2-mechanize
(package-with-python2 python-mechanize))
(define-public python-simplejson
(package
@ -6921,14 +6913,14 @@ some are not yet implemented).")
(define-public python-netifaces
(package
(name "python-netifaces")
(version "0.10.7")
(version "0.10.9")
(source
(origin
(method url-fetch)
(uri (pypi-uri "netifaces" version))
(sha256
(base32
"1gccklrcplbbqh81g1mdgpa5y8na7kkf29cq2ka3f5a2fp5hyndx"))))
"1wxby874kcr3pp4ygzk5aiarbzhg1yi093d56s1qg4k2s7yrzvid"))))
(build-system python-build-system)
(home-page "https://github.com/al45tair/netifaces")
(synopsis
@ -12581,27 +12573,26 @@ discovery, monitoring and configuration.")
(define-public python-odfpy
(package
(name "python-odfpy")
(version "1.3.3")
(version "1.4.1")
(source (origin
(method url-fetch)
(uri (pypi-uri "odfpy" version))
(sha256
(base32
"1a6ms0w9zfhhkqhvrnynwwbxrivw6hgjc0s5k7j06npc7rq0blxw"))))
"1v1qqk9p12qla85yscq2g413l3qasn6yr4ncyc934465b5p6lxnv"))))
(arguments
`(#:modules ((srfi srfi-1)
(guix build python-build-system)
(guix build utils))
#:phases
`(#:phases
(modify-phases %standard-phases
(replace 'check
;; The test runner invokes python2 and python3 for test*.py.
;; To avoid having both in inputs, we replicate it here.
(lambda _
(for-each (lambda (test-file) (invoke "python" test-file))
(find-files "tests" "^test.*\\.py$"))
#t)))))
(setenv "PYTHONPATH" (string-append "./build/lib:"
(getenv "PYTHONPATH")))
(invoke "pytest" "-vv"))))))
(build-system python-build-system)
(native-inputs
`(("python-pytest" ,python-pytest)))
(propagated-inputs
`(("python-defusedxml" ,python-defusedxml)))
(home-page "https://github.com/eea/odfpy")
(synopsis "Python API and tools to manipulate OpenDocument files")
(description "Collection of libraries and utility programs written in
@ -14147,7 +14138,7 @@ exception message with a traceback that points to the culprit.")
(define-public python-mwclient
(package
(name "python-mwclient")
(version "0.10.0")
(version "0.10.1")
(source
(origin
(method git-fetch)
@ -14157,8 +14148,7 @@ exception message with a traceback that points to the culprit.")
(commit (string-append "v" version))))
(file-name (git-file-name name version))
(sha256
(base32
"1c3q6lwmb05yqywc4ya98ca7hsl15niili8rccl4n1yqp77c103v"))))
(base32 "120snnsh9n5svfwkyj1w9jrxf99jnqm0jk282yypd3lpyca1l9hj"))))
(build-system python-build-system)
(propagated-inputs
`(("python-requests-oauthlib" ,python-requests-oauthlib)
@ -15107,16 +15097,22 @@ window memory map manager.")
(define-public python-regex
(package
(name "python-regex")
(version "2019.04.14")
(version "2020.6.8")
(source (origin
(method url-fetch)
(uri (pypi-uri "regex" version))
(sha256
(base32
"1a6hhfs6l6snr1z654ay6wzbmwdkmv282fzfkd5hk2d1n73y8v6m"))))
;; TODO: Fix and enable regex_test.py tests that complain about the
;; test.support module not existing.
"1b3k0zi1pd99q5mk7ri7vcx2y1mq5inm9hk8dryqyhrpkmh4xdp9"))))
(build-system python-build-system)
(arguments
'(#:phases
(modify-phases %standard-phases
(replace 'check
(lambda* (#:key inputs outputs #:allow-other-keys)
(add-installed-pythonpath inputs outputs)
(invoke "python" "-c"
"from regex.test_regex import test_main; test_main()"))))))
(home-page "https://bitbucket.org/mrabarnett/mrab-regex")
(synopsis "Alternative regular expression module")
(description "This regular expression implementation is backwards-

6
gnu/packages/qt.scm
View File

@ -7,7 +7,7 @@
;;; Copyright © 2016 Thomas Danckaert <post@thomasdanckaert.be>
;;; Copyright © 2017, 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2017 Quiliro <quiliro@fsfla.org>
;;; Copyright © 2017, 2018 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2017, 2018, 2020 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2018 Nicolas Goaziou <mail@nicolasgoaziou.fr>
;;; Copyright © 2018 Hartmut Goebel <h.goebel@crazy-compilers.com>
;;; Copyright © 2018 Eric Bavier <bavier@member.fsf.org>
@ -2335,7 +2335,7 @@ securely. It will not store any data unencrypted unless explicitly requested.")
(define-public qwt
(package
(name "qwt")
(version "6.1.4")
(version "6.1.5")
(source
(origin
(method url-fetch)
@ -2343,7 +2343,7 @@ securely. It will not store any data unencrypted unless explicitly requested.")
(string-append "mirror://sourceforge/qwt/qwt/"
version "/qwt-" version ".tar.bz2"))
(sha256
(base32 "1navkcnmn0qz8kzsyqmk32d929zl72l0b580w1ica7z5559j2a8m"))))
(base32 "0hf0mpca248xlqn7xnzkfj8drf19gdyg5syzklvq8pibxiixwxj0"))))
(build-system gnu-build-system)
(inputs
`(("qtbase" ,qtbase)

4
gnu/packages/skarnet.scm
View File

@ -263,7 +263,7 @@ environment.")))
(define-public s6-portable-utils
(package
(name "s6-portable-utils")
(version "2.2.2.2")
(version "2.2.2.3")
(source
(origin
(method url-fetch)
@ -271,7 +271,7 @@ environment.")))
"https://skarnet.org/software/s6-portable-utils/s6-portable-utils-"
version ".tar.gz"))
(sha256
(base32 "1k3la37q46n93vjwk9wm9ym4w87z6lqzv43f03qd0vqj9k94mpv3"))))
(base32 "0dniniw8y9das12ic7bd34ra817qzfrql18rczs49sfnkf67c98n"))))
(build-system gnu-build-system)
(inputs `(("skalibs" ,skalibs)))
(arguments

14
gnu/packages/ssh.scm
View File

@ -43,7 +43,6 @@
#:use-module (gnu packages groff)
#:use-module (gnu packages guile)
#:use-module (gnu packages libedit)
#:use-module (gnu packages hurd)
#:use-module (gnu packages linux)
#:use-module (gnu packages logging)
#:use-module (gnu packages m4)
@ -150,9 +149,7 @@ a server that supports the SSH-2 protocol.")
("pam" ,linux-pam)
("mit-krb5" ,mit-krb5)
("zlib" ,zlib)
,@(if (hurd-target?)
'()
`(("xauth" ,xauth))))) ; for 'ssh -X' and 'ssh -Y'
("xauth" ,xauth))) ; for 'ssh -X' and 'ssh -Y'
(arguments
`(#:test-target "tests"
;; Otherwise, the test scripts try to use a nonexistent directory and
@ -239,6 +236,15 @@ Additionally, various channel-specific options can be negotiated.")
"See LICENSE in the distribution."))
(home-page "https://www.openssh.com/")))
;; OpenSSH without X support. This allows to use OpenSSH without dragging X
;; libraries to the closure.
(define-public openssh-sans-x
(package
(inherit openssh)
(name "openssh-sans-x")
(inputs (alist-delete "xauth" (package-inputs openssh)))
(synopsis "OpenSSH client and server without X11 support")))
(define-public guile-ssh
(package
(name "guile-ssh")

4
gnu/packages/version-control.scm
View File

@ -634,7 +634,7 @@ on @command{git}, and use any regular Git hosting service.")
(define-public libgit2
(package
(name "libgit2")
(version "1.0.0")
(version "1.0.1")
(source (origin
(method url-fetch)
(uri (string-append "https://github.com/libgit2/libgit2/"
@ -642,7 +642,7 @@ on @command{git}, and use any regular Git hosting service.")
"/libgit2-" version ".tar.gz"))
(sha256
(base32
"1d09ni0v3vammk8zqmmwks92fh3wwnsxpyrh4s5wwdb3gxma27va"))
"0nlg35pxhh548nn7aa3y1m81mf81nkbzz86i2psps4f474n497v8"))
(patches (search-patches "libgit2-mtime-0.patch"))
(snippet '(begin
(delete-file-recursively "deps") #t))

9
gnu/packages/video.scm
View File

@ -625,6 +625,7 @@ available.")
(delete-file-recursively "source/compat/getopt")
#t))))
(build-system cmake-build-system)
(native-inputs `(("nasm" ,nasm)))
(arguments
`(#:tests? #f ; tests are skipped if cpu-optimized code isn't built
#:configure-flags
@ -1611,7 +1612,7 @@ To load this plugin, specify the following option when starting mpv:
(define-public youtube-dl
(package
(name "youtube-dl")
(version "2020.05.29")
(version "2020.06.06")
(source (origin
(method url-fetch)
(uri (string-append "https://github.com/ytdl-org/youtube-dl/"
@ -1619,7 +1620,7 @@ To load this plugin, specify the following option when starting mpv:
version ".tar.gz"))
(sha256
(base32
"111ganbfi76ipfq5gjgamjbqd7m8l4lim9wwmfnc04bzvwqqzfi3"))))
"1qrrr14glv0jv377n61paq55b6k58jpnwbz2sp5xfl4wnxy5hqny"))))
(build-system python-build-system)
(arguments
;; The problem here is that the directory for the man page and completion
@ -2253,14 +2254,14 @@ and custom quantization matrices.")
(define-public streamlink
(package
(name "streamlink")
(version "1.3.1")
(version "1.4.1")
(source
(origin
(method url-fetch)
(uri (pypi-uri "streamlink" version))
(sha256
(base32
"0cnlg3ra3g6dml4xfy9ysy9b4qwyn458fadd8ac44cfwi3v4gq6y"))))
"1s458k8z1lv0w8i82sxs8dys66fwm4yr9j1m7fzp7r0piz8phcpd"))))
(build-system python-build-system)
(home-page "https://github.com/streamlink/streamlink")
(native-inputs

28
gnu/packages/vim.scm
View File

@ -872,3 +872,31 @@ through its msgpack-rpc API.")
NeoVim) to enable you to run shell commands in background and read output in the
quickfix window in realtime.")
(license license:expat)))
(define-public vim-dispatch
(package
(name "vim-dispatch")
(version "1.8")
(source
(origin
(method git-fetch)
(uri (git-reference
(url "https://github.com/tpope/vim-dispatch")
(commit (string-append "v" version))))
(file-name (git-file-name name version))
(sha256
(base32
"1m8b5mn2zqlphzs6xfwykwmghf6p0wabrhpjmh7vav35jgcxc4wl"))))
(build-system copy-build-system)
(arguments
'(#:install-plan
'(("autoload" "share/vim/vimfiles/")
("doc" "share/vim/vimfiles/")
("plugin" "share/vim/vimfiles/"))))
(home-page "https://github.com/tpope/vim-dispatch")
(synopsis "Asynchronous build and test dispatcher")
(description "Leverage the power of Vim's compiler plugins without being
bound by synchronicity. Kick off builds and test suites using one of several
asynchronous adapters (including tmux, screen, and a headless mode), and when
the job completes, errors will be loaded and parsed automatically.")
(license license:vim)))

4
gnu/packages/vpn.scm
View File

@ -499,7 +499,7 @@ The peer-to-peer VPN implements a Layer 2 (Ethernet) network between the peers
(define-public wireguard-linux-compat
(package
(name "wireguard-linux-compat")
(version "1.0.20200401")
(version "1.0.20200520")
(source (origin
(method url-fetch)
(uri (string-append "https://git.zx2c4.com/wireguard-linux-compat/"
@ -507,7 +507,7 @@ The peer-to-peer VPN implements a Layer 2 (Ethernet) network between the peers
".tar.xz"))
(sha256
(base32
"0ymprz3h4b92wlcqm5k5vmcgap8pjv202bgkdx0axmp12n1lmyvx"))))
"1hvpbfpdd3v2k27ypa1y1j422irx7hxpz87f50s28jvkxx5sxrqn"))))
(build-system linux-module-build-system)
(outputs '("out"
"kernel-patch"))

37
gnu/services.scm
View File

@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@ -33,6 +34,7 @@
#:use-module (guix modules)
#:use-module (gnu packages base)
#:use-module (gnu packages bash)
#:use-module (gnu packages hurd)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
@ -91,6 +93,8 @@
activation-service-type
activation-service->script
%linux-bare-metal-service
%hurd-rc-script
%hurd-startup-service
special-files-service-type
extra-special-file
etc-service-type
@ -603,6 +607,39 @@ ACTIVATION-SCRIPT-TYPE."
activation-service-type
%linux-kernel-activation))
(define %hurd-rc-script
;; The RC script to be started upon boot.
(program-file "rc"
(with-imported-modules (source-module-closure
'((guix build utils)
(gnu build hurd-boot)
(guix build syscalls)))
#~(begin
(use-modules (guix build utils)
(gnu build hurd-boot)
(guix build syscalls)
(ice-9 match)
(system repl repl)
(srfi srfi-1)
(srfi srfi-26))
(boot-hurd-system)))))
(define (hurd-rc-entry rc)
"Return, as a monadic value, an entry for the RC script in the system
directory."
(mlet %store-monad ((rc (lower-object rc)))
(return `(("rc" ,rc)))))
(define hurd-startup-service-type
;; The service that creates the initial SYSTEM/rc startup file.
(service-type (name 'startup)
(extensions
(list (service-extension system-service-type hurd-rc-entry)))
(default-value %hurd-rc-script)))
(define %hurd-startup-service
;; The service that produces the RC script.
(service hurd-startup-service-type %hurd-rc-script))
(define special-files-service-type
;; Service to install "special files" such as /bin/sh and /usr/bin/env.

123
gnu/services/hurd.scm Normal file
View File

@ -0,0 +1,123 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu services hurd)
#:use-module (gnu packages admin)
#:use-module (gnu packages hurd)
#:use-module (gnu services)
#:use-module (gnu services shepherd)
#:use-module (gnu system)
#:use-module (guix gexp)
#:use-module (guix records)
#:export (hurd-console-configuration
hurd-console-service-type
hurd-getty-configuration
hurd-getty-service-type))
;;; Commentary:
;;;
;;; This module implements services for the Hurd.
;;;
;;; Code:
;;;
;;; The Hurd VGA console service.
;;;
(define-record-type* <hurd-console-configuration>
hurd-console-configuration make-hurd-console-configuration
hurd-console-configuration?
(hurd hurd-console-configuration-hurd ;package
(default hurd)))
(define (hurd-console-shepherd-service config)
"Return a <shepherd-service> for a Hurd VGA console with CONFIG."
(define console-command
#~(list
(string-append #$(hurd-console-configuration-hurd config) "/bin/console")
"-c" "/dev/vcs"
"-d" "vga"
"-d" "pc_kbd"
"-d" "generic_speaker"))
(list (shepherd-service
(documentation "Run the Hurd’s VGA console client.")
(provision '(console))
(requirement '(user-processes))
(start #~(make-forkexec-constructor #$console-command))
(stop #~(make-kill-destructor)))))
(define hurd-console-service-type
(service-type
(name 'console)
(description "Run the Hurd console client.")
(extensions
(list (service-extension shepherd-root-service-type
hurd-console-shepherd-service)))
(default-value (hurd-console-configuration))))
;;;
;;; The Hurd getty service.
;;;
(define-record-type* <hurd-getty-configuration>
hurd-getty-configuration make-hurd-getty-configuration
hurd-getty-configuration?
(hurd hurd-getty-configuration-hurd ;<package>
(default hurd))
(tty hurd-getty-configuration-tty) ;string
(baud-rate hurd-getty-configuration-baud-rate
(default 38400))) ;integer
(define (hurd-getty-shepherd-service config)
"Return a <shepherd-service> for a Hurd getty with CONFIG."
(let ((hurd (hurd-getty-configuration-hurd config))
(tty (hurd-getty-configuration-tty config))
(baud-rate (hurd-getty-configuration-baud-rate config)))
(define getty-command
#~(list
(string-append #$hurd "/libexec/getty")
#$(number->string baud-rate)
#$tty))
(list
(shepherd-service
(documentation "Run getty on a tty.")
(provision (list (string->symbol (string-append "term-" tty))))
(requirement '(user-processes console))
(start #~(make-forkexec-constructor #$getty-command))
(stop #~(make-kill-destructor))))))
(define hurd-getty-service-type
(service-type
(name 'getty)
(extensions (list (service-extension shepherd-root-service-type
hurd-getty-shepherd-service)))
(description
"Provide console login using the Hurd @command{getty} program.")))
(define* (hurd-getty-service config)
"Return a service to run the Hurd getty according to @var{config}, which
specifies the tty to run, among other things."
(service hurd-getty-service-type config))
;;; hurd.scm ends here

161
gnu/system.scm
View File

@ -9,6 +9,7 @@
;;; Copyright © 2020 Brice Waegeneire <brice@waegenei.re>
;;; Copyright © 2020 Florian Pelz <pelzflorian@pelzflorian.de>
;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <jannek@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@ -38,9 +39,11 @@
#:use-module (guix utils)
#:use-module (gnu packages base)
#:use-module (gnu packages bash)
#:use-module (gnu packages cross-base)
#:use-module (gnu packages guile)
#:use-module (gnu packages guile-xyz)
#:use-module (gnu packages admin)
#:use-module (gnu packages hurd)
#:use-module (gnu packages linux)
#:use-module (gnu packages pciutils)
#:use-module (gnu packages package-management)
@ -82,6 +85,7 @@
operating-system-packages
operating-system-host-name
operating-system-hosts-file
operating-system-hurd
operating-system-kernel
operating-system-kernel-file
operating-system-kernel-arguments
@ -127,6 +131,8 @@
operating-system-with-gc-roots
operating-system-with-provenance
hurd-default-essential-services
boot-parameters
boot-parameters?
boot-parameters-label
@ -138,6 +144,7 @@
boot-parameters-kernel
boot-parameters-kernel-arguments
boot-parameters-initrd
boot-parameters-multiboot-modules
read-boot-parameters
read-boot-parameters-file
boot-parameters->menu-entry
@ -184,6 +191,8 @@
(default '())) ; list of packages
(kernel-arguments operating-system-user-kernel-arguments
(default %default-kernel-arguments)) ; list of gexps/strings
(hurd operating-system-hurd
(default #f)) ; package
(bootloader operating-system-bootloader) ; <bootloader-configuration>
(label operating-system-label ; string
(thunked)
@ -277,7 +286,8 @@ directly by the user."
(store-mount-point boot-parameters-store-mount-point)
(kernel boot-parameters-kernel)
(kernel-arguments boot-parameters-kernel-arguments)
(initrd boot-parameters-initrd))
(initrd boot-parameters-initrd)
(multiboot-modules boot-parameters-multiboot-modules))
(define (ensure-not-/dev device)
"If DEVICE starts with a slash, return #f. This is meant to filter out
@ -308,7 +318,7 @@ file system labels."
(match (read port)
(('boot-parameters ('version 0)
('label label) ('root-device root)
('kernel linux)
('kernel kernel)
rest ...)
(boot-parameters
(label label)
@ -324,12 +334,12 @@ file system labels."
((_ entries) (map sexp->menu-entry entries))
(#f '())))
;; In the past, we would store the directory name of the kernel instead
;; of the absolute file name of its image. Detect that and correct it.
(kernel (if (string=? linux (direct-store-path linux))
(string-append linux "/"
;; In the past, we would store the directory name of linux instead of
;; the absolute file name of its image. Detect that and correct it.
(kernel (if (string=? kernel (direct-store-path kernel))
(string-append kernel "/"
(system-linux-image-file-name))
linux))
kernel))
(kernel-arguments
(match (assq 'kernel-arguments rest)
@ -343,6 +353,8 @@ file system labels."
(('initrd (? string? file))
file)))
(multiboot-modules (or (assq 'multiboot-modules rest) '()))
(store-device
;; Linux device names like "/dev/sda1" are not suitable GRUB device
;; identifiers, so we just filter them out.
@ -380,14 +392,25 @@ The object has its kernel-arguments extended in order to make it bootable."
(boot-parameters-kernel-arguments params))))))
(define (boot-parameters->menu-entry conf)
(menu-entry
(label (boot-parameters-label conf))
(device (boot-parameters-store-device conf))
(device-mount-point (boot-parameters-store-mount-point conf))
(linux (boot-parameters-kernel conf))
(linux-arguments (boot-parameters-kernel-arguments conf))
(initrd (boot-parameters-initrd conf))))
(let* ((kernel (boot-parameters-kernel conf))
(multiboot-modules (boot-parameters-multiboot-modules conf))
(multiboot? (pair? multiboot-modules)))
(menu-entry
(label (boot-parameters-label conf))
(device (boot-parameters-store-device conf))
(device-mount-point (boot-parameters-store-mount-point conf))
(linux (and (not multiboot?) kernel))
(linux-arguments (if (not multiboot?) '
(boot-parameters-kernel-arguments conf)
'()))
(initrd (boot-parameters-initrd conf))
(multiboot-kernel (and multiboot? kernel))
(multiboot-arguments (if multiboot?
(boot-parameters-kernel-arguments conf)
'()))
(multiboot-modules (if multiboot?
(boot-parameters-multiboot-modules conf)
'())))))
;;;
@ -466,21 +489,23 @@ from the initrd."
"Return the list of swap services for OS."
(map swap-service (operating-system-swap-devices os)))
(define* (system-linux-image-file-name)
"Return the basename of the kernel image file for SYSTEM."
;; FIXME: Evaluate the conditional based on the actual current system.
(let ((target (or (%current-target-system) (%current-system))))
(cond
((string-prefix? "arm" target) "zImage")
((string-prefix? "mips" target) "vmlinuz")
((string-prefix? "aarch64" target) "Image")
(else "bzImage"))))
(define* (system-linux-image-file-name #:optional
(target (or (%current-target-system)
(%current-system))))
"Return the basename of the kernel image file for TARGET."
(cond
((string-prefix? "arm" target) "zImage")
((string-prefix? "mips" target) "vmlinuz")
((string-prefix? "aarch64" target) "Image")
(else "bzImage")))
(define (operating-system-kernel-file os)
"Return an object representing the absolute file name of the kernel image of
OS."
(file-append (operating-system-kernel os)
"/" (system-linux-image-file-name)))
(if (operating-system-hurd os)
(file-append (operating-system-kernel os) "/boot/gnumach")
(file-append (operating-system-kernel os)
"/" (system-linux-image-file-name))))
(define (package-for-kernel target-kernel module-package)
"Return a package like MODULE-PACKAGE, adapted for TARGET-KERNEL, if
@ -574,6 +599,25 @@ bookkeeping."
(service firmware-service-type
(operating-system-firmware os)))))))
(define (hurd-default-essential-services os)
(list (service system-service-type '())
%boot-service
%hurd-startup-service
%activation-service
%shepherd-root-service
(service user-processes-service-type)
(account-service (append (operating-system-accounts os)
(operating-system-groups os))
(operating-system-skeletons os))
(root-file-system-service)
(service file-system-service-type '())
(service fstab-service-type
(filter file-system-needed-for-boot?
(operating-system-file-systems os)))
(pam-root-service (operating-system-pam-services os))
(operating-system-etc-service os)
(service profile-service-type (operating-system-packages os))))
(define* (operating-system-services os)
"Return all the services of OS, including \"essential\" services."
(instantiate-missing-services
@ -677,7 +721,7 @@ This is the GNU system. Welcome.\n")
(define* (operating-system-etc-service os)
"Return a <service> that builds containing the static part of the /etc
directory."
(let ((login.defs
(let* ((login.defs
(plain-file "login.defs"
(string-append
"# Default paths for non-login shells started by su(1).\n"
@ -688,10 +732,13 @@ directory."
"/run/current-system/profile/bin:"
"/run/current-system/profile/sbin\n")))
(issue (plain-file "issue" (operating-system-issue os)))
(nsswitch (plain-file "nsswitch.conf"
(name-service-switch->string
(operating-system-name-service-switch os))))
(hurd (operating-system-hurd os))
(issue (plain-file "issue" (operating-system-issue os)))
(nsswitch (operating-system-name-service-switch os))
(nsswitch (and nsswitch
(plain-file "nsswitch.conf"
(name-service-switch->string nsswitch))))
(sudoers (operating-system-sudoers-file os))
;; Startup file for POSIX-compliant login shells, which set system-wide
;; environment variables.
@ -781,7 +828,7 @@ fi\n")))
("rpc" ,(file-append net-base "/etc/rpc"))
("login.defs" ,#~#$login.defs)
("issue" ,#~#$issue)
("nsswitch.conf" ,#~#$nsswitch)
,@(if nsswitch `(("nsswitch.conf" ,#~#$nsswitch)) '())
("profile" ,#~#$profile)
("bashrc" ,#~#$bashrc)
("hosts" ,#~#$(or (operating-system-hosts-file os)
@ -797,7 +844,11 @@ fi\n")))
("timezone" ,(plain-file "timezone" (operating-system-timezone os)))
("localtime" ,(file-append tzdata "/share/zoneinfo/"
(operating-system-timezone os)))
("sudoers" ,(operating-system-sudoers-file os))))))
,@(if sudoers `(("sudoers" ,sudoers)) '())
,@(if hurd
`(("login" ,(file-append hurd "/etc/login"))
("motd" ,(file-append hurd "/etc/motd")))
'())))))
(define %root-account
;; Default root account.
@ -1062,9 +1113,13 @@ listed in OS. The C library expects to find it under
(locale-directory definitions
#:libcs (operating-system-locale-libcs os)))
(define (kernel->boot-label kernel)
(define* (kernel->boot-label kernel #:key hurd)
"Return a label for the bootloader menu entry that boots KERNEL."
(cond ((package? kernel)
(cond ((package? hurd)
(string-append "GNU with the "
(string-titlecase (package-name hurd)) " "
(package-version hurd)))
((package? kernel)
(string-append "GNU with "
(string-titlecase (package-name kernel)) " "
(package-version kernel)))
@ -1077,7 +1132,8 @@ listed in OS. The C library expects to find it under
(define (operating-system-default-label os)
"Return the default label for OS, as it will appear in the bootloader menu
entry."
(kernel->boot-label (operating-system-kernel os)))
(kernel->boot-label (operating-system-kernel os)
#:hurd (operating-system-hurd os)))
(define (store-file-system file-systems)
"Return the file system object among FILE-SYSTEMS that contains the store."
@ -1121,17 +1177,45 @@ a list of <menu-entry>, to populate the \"old entries\" menu."
#:store-directory-prefix
(btrfs-store-subvolume-file-name file-systems))))
(define (operating-system-multiboot-modules os)
(if (operating-system-hurd os) (hurd-multiboot-modules os) '()))
(define (hurd-multiboot-modules os)
(let* ((hurd (operating-system-hurd os))
(root-file-system-command
(list (file-append hurd "/hurd/ext2fs.static")
"ext2fs"
"--multiboot-command-line='${kernel-command-line}'"
"--host-priv-port='${host-port}'"
"--device-master-port='${device-port}'"
"--exec-server-task='${exec-task}'"
"--store-type=typed"
"'${root}'" "'$(task-create)'" "'$(task-resume)'"))
(target (%current-target-system))
(libc (if target
(with-parameters ((%current-target-system #f))
;; TODO: cross-libc has extra patches for the Hurd;
;; remove in next rebuild cycle
(cross-libc target))
glibc))
(exec-server-command
(list (file-append libc "/lib/ld.so.1") "exec"
(file-append hurd "/hurd/exec") "'$(exec-task=task-create)'")))
(list root-file-system-command exec-server-command)))
(define* (operating-system-boot-parameters os root-device
#:key system-kernel-arguments?)
"Return a monadic <boot-parameters> record that describes the boot
parameters of OS. When SYSTEM-KERNEL-ARGUMENTS? is true, add kernel arguments
such as '--root' and '--load' to <boot-parameters>."
(let* ((initrd (operating-system-initrd-file os))
(let* ((initrd (and (not (hurd-target?))
(operating-system-initrd-file os)))
(store (operating-system-store-file-system os))
(bootloader (bootloader-configuration-bootloader
(operating-system-bootloader os)))
(bootloader-name (bootloader-name bootloader))
(label (operating-system-label os)))
(label (operating-system-label os))
(multiboot-modules (operating-system-multiboot-modules os)))
(boot-parameters
(label label)
(root-device root-device)
@ -1141,6 +1225,7 @@ such as '--root' and '--load' to <boot-parameters>."
(operating-system-kernel-arguments os root-device)
(operating-system-user-kernel-arguments os)))
(initrd initrd)
(multiboot-modules multiboot-modules)
(bootloader-name bootloader-name)
(bootloader-menu-entries
(bootloader-configuration-menu-entries (operating-system-bootloader os)))

3
gnu/system/examples/bare-bones.tmpl
View File

@ -3,7 +3,7 @@
(use-modules (gnu))
(use-service-modules networking ssh)
(use-package-modules screen)
(use-package-modules screen ssh)
(operating-system
(host-name "komputilo")
@ -46,5 +46,6 @@
(services (append (list (service dhcp-client-service-type)
(service openssh-service-type
(openssh-configuration
(openssh openssh-sans-x)
(port-number 2222))))
%base-services)))

31
gnu/system/examples/bare-hurd.tmpl Normal file
View File

@ -0,0 +1,31 @@
;; -*-scheme-*-
;; This is an operating system configuration template
;; for a "bare bones" setup, with no X11 display server.
;; To build a disk image for a virtual machine, do
;;
;; ./pre-inst-env guix system disk-image --target=i586-pc-gnu --no-grafts \
;; gnu/system/examples/bare-hurd.tmpl
;;
;; it boots, but needs activation, more setup and services to be useful.
(use-modules (gnu) (gnu system hurd) (guix utils))
(define %hurd-os
(operating-system
(inherit %hurd-default-operating-system)
(bootloader (bootloader-configuration
(bootloader grub-minimal-bootloader)
(target "/dev/sdX")))
(file-systems (cons (file-system
(device (file-system-label "my-root"))
(mount-point "/")
(type "ext2"))
%base-file-systems))
(host-name "guixygnu")
(timezone "Europe/Amsterdam")
(packages %base-packages/hurd)
(services %base-services/hurd)))
%hurd-os

63
gnu/system/hurd.scm
View File

@ -21,6 +21,7 @@
#:use-module (guix gexp)
#:use-module (guix profiles)
#:use-module (guix utils)
#:use-module (gnu bootloader)
#:use-module (gnu bootloader grub)
#:use-module (gnu packages admin)
#:use-module (gnu packages base)
@ -31,8 +32,18 @@
#:use-module (gnu packages guile-xyz)
#:use-module (gnu packages hurd)
#:use-module (gnu packages less)
#:use-module (gnu services)
#:use-module (gnu services base)
#:use-module (gnu services hurd)
#:use-module (gnu services shepherd)
#:use-module (gnu system)
#:use-module (gnu system shadow)
#:use-module (gnu system vm)
#:export (cross-hurd-image))
#:export (cross-hurd-image
%base-packages/hurd
%base-services/hurd
%hurd-default-operating-system
%hurd-default-operating-system-kernel))
;;; Commentary:
;;;
@ -41,10 +52,58 @@
;;;
;;; Code:
(define %hurd-default-operating-system-kernel
(if (hurd-system?)
gnumach
;; A cross-built GNUmach does not work
(with-parameters ((%current-system "i686-linux")
(%current-target-system #f))
gnumach)))
(define %base-packages/hurd
(list hurd bash coreutils file findutils grep sed
guile-3.0 guile-colorized guile-readline
net-base inetutils less which))
net-base inetutils less shepherd which))
(define %base-services/hurd
(list (service hurd-console-service-type
(hurd-console-configuration (hurd hurd)))
(service hurd-getty-service-type (hurd-getty-configuration
(tty "tty1")))
(service hurd-getty-service-type (hurd-getty-configuration
(tty "tty2")))
(service static-networking-service-type
(list (static-networking (interface "lo")
(ip "127.0.0.1")
(requirement '())
(provision '(loopback))
(name-servers '("10.0.2.3")))))
(syslog-service)
(service guix-service-type
(guix-configuration
(extra-options '("--disable-chroot"
"--disable-deduplication"))))))
(define %hurd-default-operating-system
(operating-system
(kernel %hurd-default-operating-system-kernel)
(kernel-arguments '())
(hurd hurd)
(bootloader (bootloader-configuration
(bootloader grub-minimal-bootloader)
(target "/dev/vda")))
(initrd (lambda _ '()))
(initrd-modules (lambda _ '()))
(firmware '())
(host-name "guixygnu")
(file-systems '())
(packages %base-packages/hurd)
(timezone "GNUrope")
(name-service-switch #f)
(essential-services (hurd-default-essential-services this-operating-system))
(pam-services '())
(setuid-programs '())
(sudoers-file #f)))
(define* (cross-hurd-image #:key (hurd hurd) (gnumach gnumach))
"Return a cross-built GNU/Hurd image."

42
gnu/system/image.scm
View File

@ -43,6 +43,7 @@
#:use-module (gnu packages genimage)
#:use-module (gnu packages guile)
#:autoload (gnu packages gnupg) (guile-gcrypt)
#:use-module (gnu packages hurd)
#:use-module (gnu packages linux)
#:use-module (gnu packages mtools)
#:use-module ((srfi srfi-1) #:prefix srfi-1:)
@ -54,6 +55,7 @@
#:export (esp-partition
root-partition
hurd-disk-image
efi-disk-image
iso9660-image
@ -91,6 +93,26 @@
(flags '(boot))
(initializer (gexp initialize-root-partition))))
(define hurd-initialize-root-partition
#~(lambda* (#:rest args)
(apply initialize-root-partition
(append args
(list #:make-device-nodes
make-hurd-device-nodes)))))
(define hurd-disk-image
(image
(format 'disk-image)
(partitions
(list (partition
(size 'guess)
(offset root-offset)
(label root-label)
(file-system "ext2")
(file-system-options '("-o" "hurd" "-O" "ext_attr"))
(flags '(boot))
(initializer hurd-initialize-root-partition))))))
(define efi-disk-image
(image
(format 'disk-image)
@ -145,12 +167,16 @@
(with-imported-modules `(,@(source-module-closure
'((gnu build vm)
(gnu build image)
(gnu build hurd-boot)
(gnu build linux-boot)
(guix store database))
#:select? not-config?)
((guix config) => ,(make-config.scm)))
#~(begin
(use-modules (gnu build vm)
(gnu build image)
(gnu build hurd-boot)
(gnu build linux-boot)
(guix store database)
(guix build utils))
gexp* ...))))
@ -525,10 +551,16 @@ image, depending on IMAGE format."
"Find and return an image that could match the given FILE-SYSTEM-TYPE. This
is useful to adapt to interfaces written before the addition of the <image>
record."
(mbegin %store-monad
(return
(match file-system-type
("iso9660" iso9660-image)
(_ efi-disk-image)))))
(mlet %store-monad ((target (current-target-system)))
(mbegin %store-monad
(return
(match file-system-type
("iso9660" iso9660-image)
(_ (cond
((and target
(hurd-triplet? target))
hurd-disk-image)
(else
efi-disk-image))))))))
;;; image.scm ends here

11
gnu/system/install.scm
View File

@ -32,6 +32,7 @@
#:use-module ((guix packages) #:select (package-version))
#:use-module ((guix store) #:select (%store-prefix))
#:use-module (gnu installer)
#:use-module (gnu system locale)
#:use-module (gnu services dbus)
#:use-module (gnu services networking)
#:use-module (gnu services shepherd)
@ -439,10 +440,12 @@ Access documentation at any time by pressing Alt-F2.\x1b[0m
;; things needed by 'profile-derivation' to minimize the amount of
;; download.
(service gc-root-service-type
(list bare-bones-os
glibc-utf8-locales
texinfo
guile-3.0))
(append
(list bare-bones-os
glibc-utf8-locales
texinfo
guile-3.0)
%default-locale-libcs))
;; Machines without Kernel Mode Setting (those with many old and
;; current AMD GPUs, SiS GPUs, ...) need uvesafb to show the GUI

68
gnu/system/vm.scm
View File

@ -141,7 +141,7 @@
(define* (expression->derivation-in-linux-vm name exp
#:key
(system (%current-system)) target
(system (%current-system))
(linux linux-libre)
initrd
(qemu qemu-minimal)
@ -226,10 +226,11 @@ substitutable."
(let* ((native-inputs
'#+(list qemu (canonical-package coreutils)))
(linux (string-append #$linux "/"
#$(system-linux-image-file-name)))
(initrd #$initrd)
(loader #$loader)
(linux (string-append
#+linux "/"
#+(system-linux-image-file-name system)))
(initrd #+initrd)
(loader #+loader)
(graphs '#$(match references-graphs
(((graph-files . _) ...) graph-files)
(_ #f)))
@ -249,8 +250,6 @@ substitutable."
#:memory-size #$memory-size
#:make-disk-image? #$make-disk-image?
#:single-file-output? #$single-file-output?
#:target-arm32? #$(check target-arm32?)
#:target-aarch64? #$(check target-aarch64?)
#:disk-image-format #$disk-image-format
#:disk-image-size size
#:references-graphs graphs))))))
@ -258,7 +257,7 @@ substitutable."
(gexp->derivation name builder
;; TODO: Require the "kvm" feature.
#:system system
#:target target
#:target #f ;EXP is always executed natively
#:env-vars env-vars
#:guile-for-build guile-for-build
#:references-graphs references-graphs
@ -318,6 +317,21 @@ system that is passed to 'populate-root-file-system'."
(local-file (search-path %load-path
"guix/store/schema.sql"))))
(define preserve-target
(if target
(lambda (obj)
(with-parameters ((%current-target-system target))
obj))
identity))
(define inputs*
(map (match-lambda
((name thing)
`(,name ,(preserve-target thing)))
((name thing output)
`(,name ,(preserve-target thing) ,output)))
inputs))
(expression->derivation-in-linux-vm
name
(with-extensions gcrypt-sqlite3&co
@ -330,9 +344,10 @@ system that is passed to 'populate-root-file-system'."
#~(begin
(use-modules (gnu build bootloader)
(gnu build vm)
((gnu build hurd-boot)
#:select (make-hurd-device-nodes))
((gnu build linux-boot)
#:select (make-essential-device-nodes
make-hurd-device-nodes))
#:select (make-essential-device-nodes))
(guix store database)
(guix build utils)
(srfi srfi-26)
@ -346,7 +361,7 @@ system that is passed to 'populate-root-file-system'."
(setlocale LC_ALL "en_US.utf8")
(let ((inputs
'#$(append (list parted e2fsprogs dosfstools)
'#+(append (list parted e2fsprogs dosfstools)
(map canonical-package
(list sed grep coreutils findutils gawk))))
@ -356,7 +371,7 @@ system that is passed to 'populate-root-file-system'."
'#$(map (match-lambda
((name thing) thing)
((name thing output) `(,thing ,output)))
inputs)))
inputs*)))
(set-path-environment-variable "PATH" '("bin" "sbin") inputs)
@ -368,7 +383,7 @@ system that is passed to 'populate-root-file-system'."
#:closures graphs
#:copy-closures? #$copy-inputs?
#:register-closures? #$register-closures?
#:system-directory #$os
#:system-directory #$(preserve-target os)
#:make-device-nodes
#$(match device-nodes
@ -423,18 +438,17 @@ system that is passed to 'populate-root-file-system'."
#:partitions partitions
#:grub-efi grub-efi
#:bootloader-package
#$(bootloader-package bootloader)
#:bootcfg #$bootcfg-drv
#+(bootloader-package bootloader)
#:bootcfg #$(preserve-target bootcfg-drv)
#:bootcfg-location
#$(bootloader-configuration-file bootloader)
#:bootloader-installer
#$(bootloader-installer bootloader)))))))
#+(bootloader-installer bootloader)))))))
#:system system
#:target target
#:make-disk-image? #t
#:disk-image-size disk-image-size
#:disk-image-format disk-image-format
#:references-graphs inputs
#:references-graphs inputs*
#:substitutable? substitutable?))
(define* (system-docker-image os
@ -751,6 +765,8 @@ environment with the store shared with the host. MAPPINGS is a list of
(define* (system-qemu-image/shared-store
os
#:key
(system (%current-system))
(target (%current-target-system))
full-boot?
(disk-image-size (* (if full-boot? 500 30) (expt 2 20))))
"Return a derivation that builds a QEMU image of OS that shares its store
@ -771,6 +787,8 @@ bootloader refers to: OS kernel, initrd, bootloader data, etc."
;; This is more than needed (we only need the kernel, initrd, GRUB for its
;; font, and the background image), but it's hard to filter that.
(qemu-image #:os os
#:system system
#:target target
#:bootcfg-drv bootcfg
#:bootloader (bootloader-configuration-bootloader
(operating-system-bootloader os))
@ -811,6 +829,8 @@ with '-virtfs' options for the host file systems listed in SHARED-FS."
(define* (system-qemu-image/shared-store-script os
#:key
(system (%current-system))
(target (%current-target-system))
(qemu qemu)
(graphic? #t)
(memory-size 256)
@ -834,6 +854,8 @@ it is mostly useful when FULL-BOOT? is true."
(mlet* %store-monad ((os -> (virtualized-operating-system os mappings full-boot?))
(image (system-qemu-image/shared-store
os
#:system system
#:target target
#:full-boot? full-boot?
#:disk-image-size disk-image-size)))
(define kernel-arguments
@ -841,7 +863,8 @@ it is mostly useful when FULL-BOOT? is true."
#+@(operating-system-kernel-arguments os "/dev/vda1")))
(define qemu-exec
#~(list (string-append #$qemu "/bin/" #$(qemu-command (%current-system)))
#~(list #+(file-append qemu "/bin/"
(qemu-command (or target system)))
#$@(if full-boot?
#~()
#~("-kernel" #$(operating-system-kernel-file os)
@ -858,7 +881,7 @@ it is mostly useful when FULL-BOOT? is true."
#~(call-with-output-file #$output
(lambda (port)
(format port "#!~a~% exec ~a \"$@\"~%"
#$(file-append bash "/bin/sh")
#+(file-append bash "/bin/sh")
(string-join #$qemu-exec " "))
(chmod port #o555))))
@ -907,10 +930,11 @@ FORWARDINGS is a list of host-port/guest-port pairs."
(define-gexp-compiler (virtual-machine-compiler (vm <virtual-machine>)
system target)
;; XXX: SYSTEM and TARGET are ignored.
(match vm
(($ <virtual-machine> os qemu graphic? memory-size disk-image-size ())
(system-qemu-image/shared-store-script os
#:system system
#:target target
#:qemu qemu
#:graphic? graphic?
#:memory-size memory-size
@ -923,6 +947,8 @@ FORWARDINGS is a list of host-port/guest-port pairs."
"user,model=virtio-net-pci,"
(port-forwardings->qemu-options forwardings)))))
(system-qemu-image/shared-store-script os
#:system system
#:target target
#:qemu qemu
#:graphic? graphic?
#:memory-size memory-size

14
guix/build/syscalls.scm
View File

@ -1218,7 +1218,7 @@ handler if the lock is already held by another process."
;; zero.
16)
(define (set-thread-name name)
(define (set-thread-name!/linux name)
"Set the name of the calling thread to NAME. NAME is truncated to 15
bytes."
(let ((ptr (string->pointer name)))
@ -1231,7 +1231,7 @@ bytes."
(list (strerror err))
(list err))))))
(define (thread-name)
(define (thread-name/linux)
"Return the name of the calling thread as a string."
(let ((buf (make-bytevector %max-thread-name-length)))
(let-values (((ret err)
@ -1245,6 +1245,16 @@ bytes."
(list (strerror err))
(list err))))))
(define set-thread-name
(if (string-contains %host-type "linux")
set-thread-name!/linux
(const #f)))
(define thread-name
(if (string-contains %host-type "linux")
thread-name/linux
(const "")))
;;;
;;; Network interfaces.

28
guix/git-authenticate.scm
View File

@ -19,6 +19,7 @@
(define-module (guix git-authenticate)
#:use-module (git)
#:use-module (guix base16)
#:use-module ((guix git) #:select (false-if-git-not-found))
#:use-module (guix i18n)
#:use-module (guix openpgp)
#:use-module ((guix utils)
@ -145,6 +146,27 @@ return a list of authorized fingerprints."
"Return the list of OpenPGP fingerprints authorized to sign COMMIT, based on
authorizations listed in its parent commits. If one of the parent commits
does not specify anything, fall back to DEFAULT-AUTHORIZATIONS."
(define (parents-have-authorizations-file? commit)
;; Return true if at least one of the parents of COMMIT has the
;; '.guix-authorizations' file.
(find (lambda (commit)
(false-if-git-not-found
(tree-entry-bypath (commit-tree commit)
".guix-authorizations")))
(commit-parents commit)))
(define (assert-parents-lack-authorizations commit)
;; If COMMIT removes the '.guix-authorizations' file found in one of its
;; parents, raise an error.
(when (parents-have-authorizations-file? commit)
(raise (condition
(&unauthorized-commit-error (commit (commit-id commit))
(signing-key #f))
(&message
(message (format #f (G_ "commit ~a attempts \
to remove '.guix-authorizations' file")
(oid->string (commit-id commit)))))))))
(define (commit-authorizations commit)
(catch 'git-error
(lambda ()
@ -155,7 +177,11 @@ does not specify anything, fall back to DEFAULT-AUTHORIZATIONS."
(open-bytevector-input-port (blob-content blob)))))
(lambda (key error)
(if (= (git-error-code error) GIT_ENOTFOUND)
default-authorizations
(begin
;; Prevent removal of '.guix-authorizations' since it would make
;; it trivial to force a fallback to DEFAULT-AUTHORIZATIONS.
(assert-parents-lack-authorizations commit)
default-authorizations)
(throw key error)))))
(apply lset-intersection bytevector=?

29
guix/git.scm
View File

@ -39,6 +39,7 @@
honor-system-x509-certificates!
with-repository
false-if-git-not-found
update-cached-checkout
url+commit->name
latest-repository-commit
@ -243,18 +244,23 @@ Return true on success, false on failure."
(G_ "Support for submodules is missing; \
please upgrade Guile-Git.~%"))))
(define-syntax-rule (false-if-git-not-found exp)
"Evaluate EXP, returning #false if a GIT_ENOTFOUND error is raised."
(catch 'git-error
(lambda ()
exp)
(lambda (key error . rest)
(if (= GIT_ENOTFOUND (git-error-code error))
#f
(apply throw key error rest)))))
(define (reference-available? repository ref)
"Return true if REF, a reference such as '(commit . \"cabba9e\"), is
definitely available in REPOSITORY, false otherwise."
(match ref
(('commit . commit)
(catch 'git-error
(lambda ()
(->bool (commit-lookup repository (string->oid commit))))
(lambda (key error . rest)
(if (= GIT_ENOTFOUND (git-error-code error))
#f
(apply throw key error rest)))))
(false-if-git-not-found
(->bool (commit-lookup repository (string->oid commit)))))
(_
#f)))
@ -311,10 +317,13 @@ When RECURSIVE? is true, check out submodules as well, if any."
(new (and starting-commit
(commit-lookup repository oid)))
(old (and starting-commit
(commit-lookup repository
(string->oid starting-commit))))
(false-if-git-not-found
(commit-lookup repository
(string->oid starting-commit)))))
(relation (and starting-commit
(commit-relation old new))))
(if old
(commit-relation old new)
'unrelated))))
;; Reclaim file descriptors and memory mappings associated with
;; REPOSITORY as soon as possible.

85
guix/grafts.scm
View File

@ -20,10 +20,12 @@
#:use-module (guix store)
#:use-module (guix monads)
#:use-module (guix records)
#:use-module (guix combinators)
#:use-module (guix derivations)
#:use-module ((guix utils) #:select (%current-system))
#:use-module (guix sets)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
@ -183,32 +185,47 @@ references."
(set-current-state (vhash-cons key result cache))
(return result)))))))
(define (reference-origin drv item)
"Return the derivation/output pair among the inputs of DRV, recursively,
that produces ITEM. Return #f if ITEM is not produced by a derivation (i.e.,
it's a content-addressed \"source\"), or if it's not produced by a dependency
of DRV."
(define (reference-origins drv items)
"Return the derivation/output pairs among the inputs of DRV, recursively,
that produce ITEMS. Elements of ITEMS not produced by a derivation (i.e.,
it's a content-addressed \"source\"), or not produced by a dependency of DRV,
have no corresponding element in the resulting list."
(define (lookup-derivers drv result items)
;; Return RESULT augmented by all the drv/output pairs producing one of
;; ITEMS, and ITEMS stripped of matching items.
(fold2 (match-lambda*
(((output . file) result items)
(if (member file items)
(values (alist-cons drv output result)
(delete file items))
(values result items))))
result items
(derivation->output-paths drv)))
;; Perform a breadth-first traversal of the dependency graph of DRV in
;; search of the derivation that produces ITEM.
;; search of the derivations that produce ITEMS.
(let loop ((drv (list drv))
(items items)
(result '())
(visited (setq)))
(match drv
(()
#f)
result)
((drv . rest)
(if (set-contains? visited drv)
(loop rest visited)
(let ((inputs (derivation-inputs drv)))
(or (any (lambda (input)
(let ((drv (derivation-input-derivation input)))
(any (match-lambda
((output . file)
(and (string=? file item)
(cons drv output))))
(derivation->output-paths drv))))
inputs)
(loop (append rest (map derivation-input-derivation inputs))
(set-insert drv visited)))))))))
(cond ((null? items)
result)
((set-contains? visited drv)
(loop rest items result visited))
(else
(let*-values (((inputs)
(map derivation-input-derivation
(derivation-inputs drv)))
((result items)
(fold2 lookup-derivers
result items inputs)))
(loop (append rest inputs)
items result
(set-insert drv visited)))))))))
(define* (cumulative-grafts store drv grafts
#:key
@ -233,25 +250,27 @@ derivations to the corresponding set of grafts."
(_
#f)))
(define (dependency-grafts item)
(match (reference-origin drv item)
((drv . output)
;; If GRAFTS already contains a graft from DRV, do not override it.
(if (find (cut graft-origin? drv <>) grafts)
(state-return grafts)
(cumulative-grafts store drv grafts
#:outputs (list output)
#:guile guile
#:system system)))
(#f
(state-return grafts))))
(define (dependency-grafts items)
(mapm %store-monad
(lambda (drv+output)
(match drv+output
((drv . output)
;; If GRAFTS already contains a graft from DRV, do not
;; override it.
(if (find (cut graft-origin? drv <>) grafts)
(state-return grafts)
(cumulative-grafts store drv grafts
#:outputs (list output)
#:guile guile
#:system system)))))
(reference-origins drv items)))
(with-cache (cons (derivation-file-name drv) outputs)
(match (non-self-references store drv outputs)
(() ;no dependencies
(return grafts))
(deps ;one or more dependencies
(mlet %state-monad ((grafts (mapm %state-monad dependency-grafts deps)))
(mlet %state-monad ((grafts (dependency-grafts deps)))
(let ((grafts (delete-duplicates (concatenate grafts) equal?)))
(match (filter (lambda (graft)
(member (graft-origin-file-name graft) deps))

30
guix/packages.scm
View File

@ -1277,23 +1277,27 @@ to (see 'graft-derivation'.)"
(define native-grafts
(let ((->graft (input-graft store system)))
(fold-bag-dependencies (lambda (package grafts)
(match (->graft package)
(#f grafts)
(graft (cons graft grafts))))
'()
bag)))
(parameterize ((%current-system system)
(%current-target-system #f))
(fold-bag-dependencies (lambda (package grafts)
(match (->graft package)
(#f grafts)
(graft (cons graft grafts))))
'()
bag))))
(define target-grafts
(if target
(let ((->graft (input-cross-graft store target system)))
(fold-bag-dependencies (lambda (package grafts)
(match (->graft package)
(#f grafts)
(graft (cons graft grafts))))
'()
bag
#:native? #f))
(parameterize ((%current-system system)
(%current-target-system target))
(fold-bag-dependencies (lambda (package grafts)
(match (->graft package)
(#f grafts)
(graft (cons graft grafts))))
'()
bag
#:native? #f)))
'()))
;; We can end up with several identical grafts if we stumble upon packages

4
guix/tests/git.scm
View File

@ -21,7 +21,6 @@
#:use-module ((guix git) #:select (with-repository))
#:use-module (guix utils)
#:use-module (guix build utils)
#:use-module ((guix tests gnupg) #:select (with-environment-variables))
#:use-module (ice-9 match)
#:use-module (ice-9 control)
#:export (git-command
@ -77,6 +76,9 @@ Return DIRECTORY on success."
port)))
(git "add" file)
(loop rest)))
((('remove file) rest ...)
(git "rm" "-f" file)
(loop rest))
((('commit text) rest ...)
(git "commit" "-m" text)
(loop rest))

22
guix/tests/gnupg.scm
View File

@ -22,27 +22,7 @@
#:use-module (ice-9 match)
#:export (gpg-command
gpgconf-command
with-fresh-gnupg-setup
with-environment-variables))
(define (call-with-environment-variables variables thunk)
"Call THUNK with the environment VARIABLES set."
(let ((environment (environ)))
(dynamic-wind
(lambda ()
(for-each (match-lambda
((variable value)
(setenv variable value)))
variables))
thunk
(lambda ()
(environ environment)))))
(define-syntax-rule (with-environment-variables variables exp ...)
"Evaluate EXP with the given environment VARIABLES set."
(call-with-environment-variables variables
(lambda () exp ...)))
with-fresh-gnupg-setup))
(define gpg-command
(make-parameter "gpg"))

57
guix/ui.scm
View File

@ -69,6 +69,7 @@
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:use-module (ice-9 regex)
#:autoload (ice-9 popen) (open-pipe* close-pipe)
#:autoload (system base compile) (compile-file)
#:autoload (system repl repl) (start-repl)
#:autoload (system repl debug) (make-debug stack->vector)
@ -1557,6 +1558,27 @@ score, the more relevant OBJ is to REGEXPS."
zero means that PACKAGE does not match any of REGEXPS."
(relevance package regexps %package-metrics))
(define (call-with-paginated-output-port proc)
(if (isatty?* (current-output-port))
;; Set 'LESS' so that 'less' exits if everything fits on the screen (F),
;; lets ANSI escapes through (r), does not send the termcap
;; initialization string (X).
(let ((pager (with-environment-variables `(("LESS"
,(or (getenv "LESS") "FrX")))
(open-pipe* OPEN_WRITE
(or (getenv "GUIX_PAGER") (getenv "PAGER")
"less")))))
(dynamic-wind
(const #t)
(lambda () (proc pager))
(lambda () (close-pipe pager))))
(proc (current-output-port))))
(define-syntax-rule (with-paginated-output-port port exp ...)
"Evaluate EXP... with PORT bound to a port that talks to the pager if
standard output is a tty, or with PORT set to the current output port."
(call-with-paginated-output-port (lambda (port) exp ...)))
(define* (display-search-results matches port
#:key
(command "guix search")
@ -1573,30 +1595,17 @@ them. If PORT is a terminal, print at most a full screen of results."
(define (line-count str)
(string-count str #\newline))
(let loop ((matches matches))
(match matches
(((package . score) rest ...)
(let* ((links? (supports-hyperlinks? port))
(text (call-with-output-string
(lambda (port)
(print package port
#:hyperlinks? links?
#:extra-fields
`((relevance . ,score)))))))
(if (and (not (getenv "INSIDE_EMACS"))
max-rows
(> (port-line port) first-line) ;print at least one result
(> (+ 4 (line-count text) (port-line port))
max-rows))
(unless (null? rest)
(display-hint (format #f (G_ "Run @code{~a ... | less} \
to view all the results.")
command)))
(begin
(display text port)
(loop rest)))))
(()
#t))))
(with-paginated-output-port paginated
(let loop ((matches matches))
(match matches
(((package . score) rest ...)
(let* ((links? (supports-hyperlinks? port)))
(print package paginated
#:hyperlinks? links?
#:extra-fields `((relevance . ,score)))
(loop rest)))
(()
#t)))))
(define (string->generations str)

50
guix/utils.scm
View File

@ -89,7 +89,6 @@
guile-version>?
version-prefix?
string-replace-substring
arguments-from-environment-variable
file-extension
file-sans-extension
tarball-sans-extension
@ -99,6 +98,9 @@
call-with-temporary-directory
with-atomic-file-output
with-environment-variables
arguments-from-environment-variable
config-directory
cache-directory
@ -113,6 +115,38 @@
call-with-compressed-output-port
canonical-newline-port))
;;;
;;; Environment variables.
;;;
(define (call-with-environment-variables variables thunk)
"Call THUNK with the environment VARIABLES set."
(let ((environment (environ)))
(dynamic-wind
(lambda ()
(for-each (match-lambda
((variable value)
(setenv variable value)))
variables))
thunk
(lambda ()
(environ environment)))))
(define-syntax-rule (with-environment-variables variables exp ...)
"Evaluate EXP with the given environment VARIABLES set."
(call-with-environment-variables variables
(lambda () exp ...)))
(define (arguments-from-environment-variable variable)
"Retrieve value of environment variable denoted by string VARIABLE in the
form of a list of strings (`char-set:graphic' tokens) suitable for consumption
by `args-fold', if VARIABLE is defined, otherwise return an empty list."
(let ((env (getenv variable)))
(if env
(string-tokenize env char-set:graphic)
'())))
;;;
;;; Filtering & pipes.
@ -582,6 +616,11 @@ minor version numbers from version-string."
(list-prefix? (string-tokenize v1 not-dot)
(string-tokenize v2 not-dot)))))
;;;
;;; Files.
;;;
(define (file-extension file)
"Return the extension of FILE or #f if there is none."
(let ((dot (string-rindex file #\.)))
@ -634,15 +673,6 @@ REPLACEMENT."
(substring str start index)
pieces))))))))
(define (arguments-from-environment-variable variable)
"Retrieve value of environment variable denoted by string VARIABLE in the
form of a list of strings (`char-set:graphic' tokens) suitable for consumption
by `args-fold', if VARIABLE is defined, otherwise return an empty list."
(let ((env (getenv variable)))
(if env
(string-tokenize env char-set:graphic)
'())))
(define (call-with-temporary-output-file proc)
"Call PROC with a name of a temporary file and open output port to that
file; close the file and delete it when leaving the dynamic extent of this

5
nix/libstore/gc.cc
View File

@ -455,7 +455,10 @@ void LocalStore::deletePathRecursive(GCState & state, const Path & path)
throw SysError(format("unable to rename `%1%' to `%2%'") % path % tmp);
state.bytesInvalidated += size;
} catch (SysError & e) {
if (e.errNo == ENOSPC) {
/* In a Docker container, rename(2) returns EXDEV when the source
and destination are not both on the "top layer". See:
https://bugs.gnu.org/41607 */
if (e.errNo == ENOSPC || e.errNo == EXDEV) {
printMsg(lvlInfo, format("note: can't create move `%1%': %2%") % path % e.msg());
deleteGarbage(state, path);
}

41
tests/git-authenticate.scm
View File

@ -282,5 +282,46 @@
merge master3)
#:keyring-reference "master"))))))
(unless (gpg+git-available?) (test-skip 1))
(test-assert "signed commits, .guix-authorizations removed"
(with-fresh-gnupg-setup (list %ed25519-public-key-file
%ed25519-secret-key-file)
(with-temporary-git-repository directory
`((add "signer.key" ,(call-with-input-file %ed25519-public-key-file
get-string-all))
(add ".guix-authorizations"
,(object->string
`(authorizations (version 0)
((,(key-fingerprint
%ed25519-public-key-file)
(name "Charlie"))))))
(commit "zeroth commit")
(add "a.txt" "A")
(commit "first commit"
(signer ,(key-fingerprint %ed25519-public-key-file)))
(remove ".guix-authorizations")
(commit "second commit"
(signer ,(key-fingerprint %ed25519-public-key-file)))
(add "b.txt" "B")
(commit "third commit"
(signer ,(key-fingerprint %ed25519-public-key-file))))
(with-repository directory repository
(let ((commit1 (find-commit repository "first"))
(commit2 (find-commit repository "second"))
(commit3 (find-commit repository "third")))
;; COMMIT1 and COMMIT2 are fine.
(and (authenticate-commits repository (list commit1 commit2)
#:keyring-reference "master")
;; COMMIT3 is rejected because COMMIT2 removes
;; '.guix-authorizations'.
(guard (c ((unauthorized-commit-error? c)
(oid=? (git-authentication-error-commit c)
(commit-id commit2))))
(authenticate-commits repository
(list commit1 commit2 commit3)
#:keyring-reference "master")
'failed)))))))
(test-end "git-authenticate")

7
tests/guix-system.sh
View File

@ -307,7 +307,12 @@ guix system search anonym network | grep "^name: tor"
# Verify that the examples can be built.
for example in gnu/system/examples/*.tmpl; do
guix system -n disk-image "$example"
if echo "$example" | grep hurd; then
target="--target=i586-pc-gnu"
else
target=
fi
guix system -n disk-image $target "$example"
done
# Verify that the disk image types can be built.

33
tests/packages.scm
View File

@ -1006,6 +1006,39 @@
(assoc-ref (bag-build-inputs bag) "libc")
(assoc-ref (bag-build-inputs bag) "coreutils"))))
(test-assert "package->bag, sensitivity to %current-target-system"
;; https://bugs.gnu.org/41713
(let* ((lower (lambda* (name #:key system target inputs native-inputs
#:allow-other-keys)
(and (not target)
(bag (name name) (system system) (target target)
(build-inputs native-inputs)
(host-inputs inputs)
(build (lambda* (store name inputs
#:key system target
#:allow-other-keys)
(build-expression->derivation
store "foo" '(mkdir %output))))))))
(bs (build-system
(name 'build-system-without-cross-compilation)
(description "Does not support cross compilation.")
(lower lower)))
(dep (dummy-package "dep" (build-system bs)))
(pkg (dummy-package "example"
(native-inputs `(("dep" ,dep)))))
(do-not-build (lambda (continue store lst . _) lst)))
(equal? (with-build-handler do-not-build
(parameterize ((%current-target-system "powerpc64le-linux-gnu")
(%graft? #t))
(package-cross-derivation %store pkg
(%current-target-system)
#:graft? #t)))
(with-build-handler do-not-build
(package-cross-derivation %store
(package (inherit pkg))
"powerpc64le-linux-gnu"
#:graft? #t)))))
(test-equal "package->bag, cross-compilation"
`(,(%current-system) "foo86-hurd"
(,(package-source gnu-make))