mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-11-07 15:36:20 -05:00
services: base: Use 'match-record' instead of 'match'.
* gnu/services/base.scm (agetty-shepherd-service) (mingetty-shepherd-service) (nscd.conf-file) (udev-shepherd-service) (udev-etc) (gpm-shepherd-service) (network-set-up/linux) (network-tear-down/linux) (static-networking-shepherd-service) (greetd-agreety-tty-session-command) (greetd-agreety-tty-xdg-session-command): Use 'match-record' instead of 'match'. (guix-accounts): Use <guix-configuration> accessors. (udev-service-type): Use <udev-configuration> accessors.
This commit is contained in:
Ludovic Courtès
parent
93d37985da
commit
156a881001
1 changed files with 440 additions and 442 deletions
|
|
@ -977,148 +977,148 @@ (define (default-serial-port)
|
|||
((device-name _ ...)
|
||||
device-name))))))))
|
||||
|
||||
(define agetty-shepherd-service
|
||||
(match-lambda
|
||||
(($ <agetty-configuration> agetty tty term baud-rate auto-login
|
||||
login-program login-pause? eight-bits? no-reset? remote? flow-control?
|
||||
host no-issue? init-string no-clear? local-line extract-baud?
|
||||
skip-login? no-newline? login-options chroot hangup? keep-baud? timeout
|
||||
detect-case? wait-cr? no-hints? no-hostname? long-hostname?
|
||||
erase-characters kill-characters chdir delay nice extra-options
|
||||
shepherd-requirement)
|
||||
(list
|
||||
(shepherd-service
|
||||
(documentation "Run agetty on a tty.")
|
||||
(provision (list (symbol-append 'term- (string->symbol (or tty "console")))))
|
||||
(define (agetty-shepherd-service config)
|
||||
(match-record config <agetty-configuration>
|
||||
(agetty tty term baud-rate auto-login
|
||||
login-program login-pause? eight-bits? no-reset? remote? flow-control?
|
||||
host no-issue? init-string no-clear? local-line extract-baud?
|
||||
skip-login? no-newline? login-options chroot hangup? keep-baud? timeout
|
||||
detect-case? wait-cr? no-hints? no-hostname? long-hostname?
|
||||
erase-characters kill-characters chdir delay nice extra-options
|
||||
shepherd-requirement)
|
||||
(list
|
||||
(shepherd-service
|
||||
(documentation "Run agetty on a tty.")
|
||||
(provision (list (symbol-append 'term- (string->symbol (or tty "console")))))
|
||||
|
||||
;; Since the login prompt shows the host name, wait for the 'host-name'
|
||||
;; service to be done. Also wait for udev essentially so that the tty
|
||||
;; text is not lost in the middle of kernel messages (see also
|
||||
;; mingetty-shepherd-service).
|
||||
(requirement (cons* 'user-processes 'host-name 'udev
|
||||
shepherd-requirement))
|
||||
;; Since the login prompt shows the host name, wait for the 'host-name'
|
||||
;; service to be done. Also wait for udev essentially so that the tty
|
||||
;; text is not lost in the middle of kernel messages (see also
|
||||
;; mingetty-shepherd-service).
|
||||
(requirement (cons* 'user-processes 'host-name 'udev
|
||||
shepherd-requirement))
|
||||
|
||||
(modules '((ice-9 match) (gnu build linux-boot)))
|
||||
(start
|
||||
(with-imported-modules (source-module-closure
|
||||
'((gnu build linux-boot)))
|
||||
#~(lambda args
|
||||
(let ((defaulted-tty #$(or tty (default-serial-port))))
|
||||
(apply
|
||||
(if defaulted-tty
|
||||
(make-forkexec-constructor
|
||||
(list #$(file-append util-linux "/sbin/agetty")
|
||||
#$@extra-options
|
||||
#$@(if eight-bits?
|
||||
#~("--8bits")
|
||||
#~())
|
||||
#$@(if no-reset?
|
||||
#~("--noreset")
|
||||
#~())
|
||||
#$@(if remote?
|
||||
#~("--remote")
|
||||
#~())
|
||||
#$@(if flow-control?
|
||||
#~("--flow-control")
|
||||
#~())
|
||||
#$@(if host
|
||||
#~("--host" #$host)
|
||||
#~())
|
||||
#$@(if no-issue?
|
||||
#~("--noissue")
|
||||
#~())
|
||||
#$@(if init-string
|
||||
#~("--init-string" #$init-string)
|
||||
#~())
|
||||
#$@(if no-clear?
|
||||
#~("--noclear")
|
||||
#~())
|
||||
(modules '((ice-9 match) (gnu build linux-boot)))
|
||||
(start
|
||||
(with-imported-modules (source-module-closure
|
||||
'((gnu build linux-boot)))
|
||||
#~(lambda args
|
||||
(let ((defaulted-tty #$(or tty (default-serial-port))))
|
||||
(apply
|
||||
(if defaulted-tty
|
||||
(make-forkexec-constructor
|
||||
(list #$(file-append util-linux "/sbin/agetty")
|
||||
#$@extra-options
|
||||
#$@(if eight-bits?
|
||||
#~("--8bits")
|
||||
#~())
|
||||
#$@(if no-reset?
|
||||
#~("--noreset")
|
||||
#~())
|
||||
#$@(if remote?
|
||||
#~("--remote")
|
||||
#~())
|
||||
#$@(if flow-control?
|
||||
#~("--flow-control")
|
||||
#~())
|
||||
#$@(if host
|
||||
#~("--host" #$host)
|
||||
#~())
|
||||
#$@(if no-issue?
|
||||
#~("--noissue")
|
||||
#~())
|
||||
#$@(if init-string
|
||||
#~("--init-string" #$init-string)
|
||||
#~())
|
||||
#$@(if no-clear?
|
||||
#~("--noclear")
|
||||
#~())
|
||||
;;; FIXME This doesn't work as expected. According to agetty(8), if this option
|
||||
;;; is not passed, then the default is 'auto'. However, in my tests, when that
|
||||
;;; option is selected, agetty never presents the login prompt, and the
|
||||
;;; term-ttyS0 service respawns every few seconds.
|
||||
#$@(if local-line
|
||||
#~(#$(match local-line
|
||||
('auto "--local-line=auto")
|
||||
('always "--local-line=always")
|
||||
('never "-local-line=never")))
|
||||
#~())
|
||||
#$@(if tty
|
||||
#~()
|
||||
#~("--keep-baud"))
|
||||
#$@(if extract-baud?
|
||||
#~("--extract-baud")
|
||||
#~())
|
||||
#$@(if skip-login?
|
||||
#~("--skip-login")
|
||||
#~())
|
||||
#$@(if no-newline?
|
||||
#~("--nonewline")
|
||||
#~())
|
||||
#$@(if login-options
|
||||
#~("--login-options" #$login-options)
|
||||
#~())
|
||||
#$@(if chroot
|
||||
#~("--chroot" #$chroot)
|
||||
#~())
|
||||
#$@(if hangup?
|
||||
#~("--hangup")
|
||||
#~())
|
||||
#$@(if keep-baud?
|
||||
#~("--keep-baud")
|
||||
#~())
|
||||
#$@(if timeout
|
||||
#~("--timeout" #$(number->string timeout))
|
||||
#~())
|
||||
#$@(if detect-case?
|
||||
#~("--detect-case")
|
||||
#~())
|
||||
#$@(if wait-cr?
|
||||
#~("--wait-cr")
|
||||
#~())
|
||||
#$@(if no-hints?
|
||||
#~("--nohints?")
|
||||
#~())
|
||||
#$@(if no-hostname?
|
||||
#~("--nohostname")
|
||||
#~())
|
||||
#$@(if long-hostname?
|
||||
#~("--long-hostname")
|
||||
#~())
|
||||
#$@(if erase-characters
|
||||
#~("--erase-chars" #$erase-characters)
|
||||
#~())
|
||||
#$@(if kill-characters
|
||||
#~("--kill-chars" #$kill-characters)
|
||||
#~())
|
||||
#$@(if chdir
|
||||
#~("--chdir" #$chdir)
|
||||
#~())
|
||||
#$@(if delay
|
||||
#~("--delay" #$(number->string delay))
|
||||
#~())
|
||||
#$@(if nice
|
||||
#~("--nice" #$(number->string nice))
|
||||
#~())
|
||||
#$@(if auto-login
|
||||
(list "--autologin" auto-login)
|
||||
'())
|
||||
#$@(if login-program
|
||||
#~("--login-program" #$login-program)
|
||||
#~())
|
||||
#$@(if login-pause?
|
||||
#~("--login-pause")
|
||||
#~())
|
||||
defaulted-tty
|
||||
#$@(if baud-rate
|
||||
#~(#$baud-rate)
|
||||
#~())
|
||||
#$@(if term
|
||||
#~(#$term)
|
||||
#~())))
|
||||
(const #f)) ; never start.
|
||||
args)))))
|
||||
(stop #~(make-kill-destructor)))))))
|
||||
#$@(if local-line
|
||||
#~(#$(match local-line
|
||||
('auto "--local-line=auto")
|
||||
('always "--local-line=always")
|
||||
('never "-local-line=never")))
|
||||
#~())
|
||||
#$@(if tty
|
||||
#~()
|
||||
#~("--keep-baud"))
|
||||
#$@(if extract-baud?
|
||||
#~("--extract-baud")
|
||||
#~())
|
||||
#$@(if skip-login?
|
||||
#~("--skip-login")
|
||||
#~())
|
||||
#$@(if no-newline?
|
||||
#~("--nonewline")
|
||||
#~())
|
||||
#$@(if login-options
|
||||
#~("--login-options" #$login-options)
|
||||
#~())
|
||||
#$@(if chroot
|
||||
#~("--chroot" #$chroot)
|
||||
#~())
|
||||
#$@(if hangup?
|
||||
#~("--hangup")
|
||||
#~())
|
||||
#$@(if keep-baud?
|
||||
#~("--keep-baud")
|
||||
#~())
|
||||
#$@(if timeout
|
||||
#~("--timeout" #$(number->string timeout))
|
||||
#~())
|
||||
#$@(if detect-case?
|
||||
#~("--detect-case")
|
||||
#~())
|
||||
#$@(if wait-cr?
|
||||
#~("--wait-cr")
|
||||
#~())
|
||||
#$@(if no-hints?
|
||||
#~("--nohints?")
|
||||
#~())
|
||||
#$@(if no-hostname?
|
||||
#~("--nohostname")
|
||||
#~())
|
||||
#$@(if long-hostname?
|
||||
#~("--long-hostname")
|
||||
#~())
|
||||
#$@(if erase-characters
|
||||
#~("--erase-chars" #$erase-characters)
|
||||
#~())
|
||||
#$@(if kill-characters
|
||||
#~("--kill-chars" #$kill-characters)
|
||||
#~())
|
||||
#$@(if chdir
|
||||
#~("--chdir" #$chdir)
|
||||
#~())
|
||||
#$@(if delay
|
||||
#~("--delay" #$(number->string delay))
|
||||
#~())
|
||||
#$@(if nice
|
||||
#~("--nice" #$(number->string nice))
|
||||
#~())
|
||||
#$@(if auto-login
|
||||
(list "--autologin" auto-login)
|
||||
'())
|
||||
#$@(if login-program
|
||||
#~("--login-program" #$login-program)
|
||||
#~())
|
||||
#$@(if login-pause?
|
||||
#~("--login-pause")
|
||||
#~())
|
||||
defaulted-tty
|
||||
#$@(if baud-rate
|
||||
#~(#$baud-rate)
|
||||
#~())
|
||||
#$@(if term
|
||||
#~(#$term)
|
||||
#~())))
|
||||
(const #f)) ; never start.
|
||||
args)))))
|
||||
(stop #~(make-kill-destructor))))))
|
||||
|
||||
(define agetty-service-type
|
||||
(service-type (name 'agetty)
|
||||
|
|
@ -1148,42 +1148,42 @@ (define-record-type* <mingetty-configuration>
|
|||
(clear-on-logout? mingetty-clear-on-logout? ;Boolean
|
||||
(default #t)))
|
||||
|
||||
(define mingetty-shepherd-service
|
||||
(match-lambda
|
||||
(($ <mingetty-configuration> mingetty tty auto-login login-program
|
||||
login-pause? clear-on-logout?)
|
||||
(list
|
||||
(shepherd-service
|
||||
(documentation "Run mingetty on an tty.")
|
||||
(provision (list (symbol-append 'term- (string->symbol tty))))
|
||||
(define (mingetty-shepherd-service config)
|
||||
(match-record config <mingetty-configuration>
|
||||
(mingetty tty auto-login login-program
|
||||
login-pause? clear-on-logout?)
|
||||
(list
|
||||
(shepherd-service
|
||||
(documentation "Run mingetty on an tty.")
|
||||
(provision (list (symbol-append 'term- (string->symbol tty))))
|
||||
|
||||
;; Since the login prompt shows the host name, wait for the 'host-name'
|
||||
;; service to be done. Also wait for udev essentially so that the tty
|
||||
;; text is not lost in the middle of kernel messages (XXX).
|
||||
(requirement '(user-processes host-name udev virtual-terminal))
|
||||
;; Since the login prompt shows the host name, wait for the 'host-name'
|
||||
;; service to be done. Also wait for udev essentially so that the tty
|
||||
;; text is not lost in the middle of kernel messages (XXX).
|
||||
(requirement '(user-processes host-name udev virtual-terminal))
|
||||
|
||||
(start #~(make-forkexec-constructor
|
||||
(list #$(file-append mingetty "/sbin/mingetty")
|
||||
(start #~(make-forkexec-constructor
|
||||
(list #$(file-append mingetty "/sbin/mingetty")
|
||||
|
||||
;; Avoiding 'vhangup' allows us to avoid 'setfont'
|
||||
;; errors down the path where various ioctls get
|
||||
;; EIO--see 'hung_up_tty_ioctl' in driver/tty/tty_io.c
|
||||
;; in Linux.
|
||||
"--nohangup" #$tty
|
||||
;; Avoiding 'vhangup' allows us to avoid 'setfont'
|
||||
;; errors down the path where various ioctls get
|
||||
;; EIO--see 'hung_up_tty_ioctl' in driver/tty/tty_io.c
|
||||
;; in Linux.
|
||||
"--nohangup" #$tty
|
||||
|
||||
#$@(if clear-on-logout?
|
||||
#~()
|
||||
#~("--noclear"))
|
||||
#$@(if auto-login
|
||||
#~("--autologin" #$auto-login)
|
||||
#~())
|
||||
#$@(if login-program
|
||||
#~("--loginprog" #$login-program)
|
||||
#~())
|
||||
#$@(if login-pause?
|
||||
#~("--loginpause")
|
||||
#~()))))
|
||||
(stop #~(make-kill-destructor)))))))
|
||||
#$@(if clear-on-logout?
|
||||
#~()
|
||||
#~("--noclear"))
|
||||
#$@(if auto-login
|
||||
#~("--autologin" #$auto-login)
|
||||
#~())
|
||||
#$@(if login-program
|
||||
#~("--loginprog" #$login-program)
|
||||
#~())
|
||||
#$@(if login-pause?
|
||||
#~("--loginpause")
|
||||
#~()))))
|
||||
(stop #~(make-kill-destructor))))))
|
||||
|
||||
(define mingetty-service-type
|
||||
(service-type (name 'mingetty)
|
||||
|
|
@ -1260,46 +1260,47 @@ (define %nscd-default-configuration
|
|||
(define (nscd.conf-file config)
|
||||
"Return the @file{nscd.conf} configuration file for @var{config}, an
|
||||
@code{<nscd-configuration>} object."
|
||||
(define cache->config
|
||||
(match-lambda
|
||||
(($ <nscd-cache> (= symbol->string database)
|
||||
positive-ttl negative-ttl size check-files?
|
||||
persistent? shared? max-size propagate?)
|
||||
(string-append "\nenable-cache\t" database "\tyes\n"
|
||||
(define (cache->config cache)
|
||||
(match-record cache <nscd-cache>
|
||||
(database positive-time-to-live negative-time-to-live
|
||||
suggested-size check-files?
|
||||
persistent? shared? max-database-size auto-propagate?)
|
||||
(let ((database (symbol->string database)))
|
||||
(string-append "\nenable-cache\t" database "\tyes\n"
|
||||
|
||||
"positive-time-to-live\t" database "\t"
|
||||
(number->string positive-ttl) "\n"
|
||||
"negative-time-to-live\t" database "\t"
|
||||
(number->string negative-ttl) "\n"
|
||||
"suggested-size\t" database "\t"
|
||||
(number->string size) "\n"
|
||||
"check-files\t" database "\t"
|
||||
(if check-files? "yes\n" "no\n")
|
||||
"persistent\t" database "\t"
|
||||
(if persistent? "yes\n" "no\n")
|
||||
"shared\t" database "\t"
|
||||
(if shared? "yes\n" "no\n")
|
||||
"max-db-size\t" database "\t"
|
||||
(number->string max-size) "\n"
|
||||
"auto-propagate\t" database "\t"
|
||||
(if propagate? "yes\n" "no\n")))))
|
||||
"positive-time-to-live\t" database "\t"
|
||||
(number->string positive-time-to-live) "\n"
|
||||
"negative-time-to-live\t" database "\t"
|
||||
(number->string negative-time-to-live) "\n"
|
||||
"suggested-size\t" database "\t"
|
||||
(number->string suggested-size) "\n"
|
||||
"check-files\t" database "\t"
|
||||
(if check-files? "yes\n" "no\n")
|
||||
"persistent\t" database "\t"
|
||||
(if persistent? "yes\n" "no\n")
|
||||
"shared\t" database "\t"
|
||||
(if shared? "yes\n" "no\n")
|
||||
"max-db-size\t" database "\t"
|
||||
(number->string max-database-size) "\n"
|
||||
"auto-propagate\t" database "\t"
|
||||
(if auto-propagate? "yes\n" "no\n")))))
|
||||
|
||||
(match config
|
||||
(($ <nscd-configuration> log-file debug-level caches)
|
||||
(plain-file "nscd.conf"
|
||||
(string-append "\
|
||||
(match-record config <nscd-configuration>
|
||||
(log-file debug-level caches)
|
||||
(plain-file "nscd.conf"
|
||||
(string-append "\
|
||||
# Configuration of libc's name service cache daemon (nscd).\n\n"
|
||||
(if log-file
|
||||
(string-append "logfile\t" log-file)
|
||||
"")
|
||||
"\n"
|
||||
(if debug-level
|
||||
(string-append "debug-level\t"
|
||||
(number->string debug-level))
|
||||
"")
|
||||
"\n"
|
||||
(string-concatenate
|
||||
(map cache->config caches)))))))
|
||||
(if log-file
|
||||
(string-append "logfile\t" log-file)
|
||||
"")
|
||||
"\n"
|
||||
(if debug-level
|
||||
(string-append "debug-level\t"
|
||||
(number->string debug-level))
|
||||
"")
|
||||
"\n"
|
||||
(string-concatenate
|
||||
(map cache->config caches))))))
|
||||
|
||||
(define (nscd-action-procedure nscd config option)
|
||||
;; XXX: This is duplicated from mcron; factorize.
|
||||
|
|
@ -1797,17 +1798,15 @@ (define discover?
|
|||
|
||||
(define (guix-accounts config)
|
||||
"Return the user accounts and user groups for CONFIG."
|
||||
(match config
|
||||
(($ <guix-configuration> _ build-group build-accounts)
|
||||
(cons (user-group
|
||||
(name build-group)
|
||||
(system? #t)
|
||||
(cons (user-group
|
||||
(name (guix-configuration-build-group config))
|
||||
(system? #t)
|
||||
|
||||
;; Use a fixed GID so that we can create the store with the right
|
||||
;; owner.
|
||||
(id 30000))
|
||||
(guix-build-accounts build-accounts
|
||||
#:group build-group)))))
|
||||
;; Use a fixed GID so that we can create the store with the right
|
||||
;; owner.
|
||||
(id 30000))
|
||||
(guix-build-accounts (guix-configuration-build-accounts config)
|
||||
#:group (guix-configuration-build-group config))))
|
||||
|
||||
(define (guix-activation config)
|
||||
"Return the activation gexp for CONFIG."
|
||||
|
|
@ -2130,95 +2129,94 @@ (define kvm-udev-rule
|
|||
(udev-rule "90-kvm.rules"
|
||||
"KERNEL==\"kvm\", GROUP=\"kvm\", MODE=\"0660\"\n"))
|
||||
|
||||
(define udev-shepherd-service
|
||||
(define (udev-shepherd-service config)
|
||||
;; Return a <shepherd-service> for UDEV with RULES.
|
||||
(match-lambda
|
||||
(($ <udev-configuration> udev)
|
||||
(list
|
||||
(shepherd-service
|
||||
(provision '(udev))
|
||||
(let ((udev (udev-configuration-udev config)))
|
||||
(list
|
||||
(shepherd-service
|
||||
(provision '(udev))
|
||||
|
||||
;; Udev needs /dev to be a 'devtmpfs' mount so that new device nodes can
|
||||
;; be added: see
|
||||
;; <http://www.linuxfromscratch.org/lfs/view/development/chapter07/udev.html>.
|
||||
(requirement '(root-file-system))
|
||||
;; Udev needs /dev to be a 'devtmpfs' mount so that new device nodes can
|
||||
;; be added: see
|
||||
;; <http://www.linuxfromscratch.org/lfs/view/development/chapter07/udev.html>.
|
||||
(requirement '(root-file-system))
|
||||
|
||||
(documentation "Populate the /dev directory, dynamically.")
|
||||
(start
|
||||
(with-imported-modules (source-module-closure
|
||||
'((gnu build linux-boot)))
|
||||
#~(lambda ()
|
||||
(define udevd
|
||||
;; 'udevd' from eudev.
|
||||
#$(file-append udev "/sbin/udevd"))
|
||||
(documentation "Populate the /dev directory, dynamically.")
|
||||
(start
|
||||
(with-imported-modules (source-module-closure
|
||||
'((gnu build linux-boot)))
|
||||
#~(lambda ()
|
||||
(define udevd
|
||||
;; 'udevd' from eudev.
|
||||
#$(file-append udev "/sbin/udevd"))
|
||||
|
||||
(define (wait-for-udevd)
|
||||
;; Wait until someone's listening on udevd's control
|
||||
;; socket.
|
||||
(let ((sock (socket AF_UNIX SOCK_SEQPACKET 0)))
|
||||
(let try ()
|
||||
(catch 'system-error
|
||||
(lambda ()
|
||||
(connect sock PF_UNIX "/run/udev/control")
|
||||
(close-port sock))
|
||||
(lambda args
|
||||
(format #t "waiting for udevd...~%")
|
||||
(usleep 500000)
|
||||
(try))))))
|
||||
(define (wait-for-udevd)
|
||||
;; Wait until someone's listening on udevd's control
|
||||
;; socket.
|
||||
(let ((sock (socket AF_UNIX SOCK_SEQPACKET 0)))
|
||||
(let try ()
|
||||
(catch 'system-error
|
||||
(lambda ()
|
||||
(connect sock PF_UNIX "/run/udev/control")
|
||||
(close-port sock))
|
||||
(lambda args
|
||||
(format #t "waiting for udevd...~%")
|
||||
(usleep 500000)
|
||||
(try))))))
|
||||
|
||||
;; Allow udev to find the modules.
|
||||
(setenv "LINUX_MODULE_DIRECTORY"
|
||||
"/run/booted-system/kernel/lib/modules")
|
||||
;; Allow udev to find the modules.
|
||||
(setenv "LINUX_MODULE_DIRECTORY"
|
||||
"/run/booted-system/kernel/lib/modules")
|
||||
|
||||
(let* ((kernel-release
|
||||
(utsname:release (uname)))
|
||||
(linux-module-directory
|
||||
(getenv "LINUX_MODULE_DIRECTORY"))
|
||||
(directory
|
||||
(string-append linux-module-directory "/"
|
||||
kernel-release))
|
||||
(old-umask (umask #o022)))
|
||||
;; If we're in a container, DIRECTORY might not exist,
|
||||
;; for instance because the host runs a different
|
||||
;; kernel. In that case, skip it; we'll just miss a few
|
||||
;; nodes like /dev/fuse.
|
||||
(when (file-exists? directory)
|
||||
(make-static-device-nodes directory))
|
||||
(umask old-umask))
|
||||
(let* ((kernel-release
|
||||
(utsname:release (uname)))
|
||||
(linux-module-directory
|
||||
(getenv "LINUX_MODULE_DIRECTORY"))
|
||||
(directory
|
||||
(string-append linux-module-directory "/"
|
||||
kernel-release))
|
||||
(old-umask (umask #o022)))
|
||||
;; If we're in a container, DIRECTORY might not exist,
|
||||
;; for instance because the host runs a different
|
||||
;; kernel. In that case, skip it; we'll just miss a few
|
||||
;; nodes like /dev/fuse.
|
||||
(when (file-exists? directory)
|
||||
(make-static-device-nodes directory))
|
||||
(umask old-umask))
|
||||
|
||||
(let ((pid (fork+exec-command
|
||||
(list udevd)
|
||||
#:environment-variables
|
||||
(cons*
|
||||
;; The first one is for udev, the second one for
|
||||
;; eudev.
|
||||
"UDEV_CONFIG_FILE=/etc/udev/udev.conf"
|
||||
"EUDEV_RULES_DIRECTORY=/etc/udev/rules.d"
|
||||
(string-append "LINUX_MODULE_DIRECTORY="
|
||||
(getenv "LINUX_MODULE_DIRECTORY"))
|
||||
(default-environment-variables)))))
|
||||
;; Wait until udevd is up and running. This appears to
|
||||
;; be needed so that the events triggered below are
|
||||
;; actually handled.
|
||||
(wait-for-udevd)
|
||||
(let ((pid (fork+exec-command
|
||||
(list udevd)
|
||||
#:environment-variables
|
||||
(cons*
|
||||
;; The first one is for udev, the second one for
|
||||
;; eudev.
|
||||
"UDEV_CONFIG_FILE=/etc/udev/udev.conf"
|
||||
"EUDEV_RULES_DIRECTORY=/etc/udev/rules.d"
|
||||
(string-append "LINUX_MODULE_DIRECTORY="
|
||||
(getenv "LINUX_MODULE_DIRECTORY"))
|
||||
(default-environment-variables)))))
|
||||
;; Wait until udevd is up and running. This appears to
|
||||
;; be needed so that the events triggered below are
|
||||
;; actually handled.
|
||||
(wait-for-udevd)
|
||||
|
||||
;; Trigger device node creation.
|
||||
(system* #$(file-append udev "/bin/udevadm")
|
||||
"trigger" "--action=add")
|
||||
;; Trigger device node creation.
|
||||
(system* #$(file-append udev "/bin/udevadm")
|
||||
"trigger" "--action=add")
|
||||
|
||||
;; Wait for things to settle down.
|
||||
(system* #$(file-append udev "/bin/udevadm")
|
||||
"settle")
|
||||
pid))))
|
||||
(stop #~(make-kill-destructor))
|
||||
;; Wait for things to settle down.
|
||||
(system* #$(file-append udev "/bin/udevadm")
|
||||
"settle")
|
||||
pid))))
|
||||
(stop #~(make-kill-destructor))
|
||||
|
||||
;; When halting the system, 'udev' is actually killed by
|
||||
;; 'user-processes', i.e., before its own 'stop' method was called.
|
||||
;; Thus, make sure it is not respawned.
|
||||
(respawn? #f)
|
||||
;; We need additional modules.
|
||||
(modules `((gnu build linux-boot) ;'make-static-device-nodes'
|
||||
,@%default-modules)))))))
|
||||
;; When halting the system, 'udev' is actually killed by
|
||||
;; 'user-processes', i.e., before its own 'stop' method was called.
|
||||
;; Thus, make sure it is not respawned.
|
||||
(respawn? #f)
|
||||
;; We need additional modules.
|
||||
(modules `((gnu build linux-boot) ;'make-static-device-nodes'
|
||||
,@%default-modules))))))
|
||||
|
||||
(define udev.conf
|
||||
(computed-file "udev.conf"
|
||||
|
|
@ -2226,14 +2224,15 @@ (define udev.conf
|
|||
(lambda (port)
|
||||
(format port "udev_rules=\"/etc/udev/rules.d\"~%")))))
|
||||
|
||||
(define udev-etc
|
||||
(match-lambda
|
||||
(($ <udev-configuration> udev rules)
|
||||
`(("udev"
|
||||
,(file-union
|
||||
"udev" `(("udev.conf" ,udev.conf)
|
||||
("rules.d" ,(udev-rules-union (cons* udev kvm-udev-rule
|
||||
rules))))))))))
|
||||
(define (udev-etc config)
|
||||
(match-record config <udev-configuration>
|
||||
(udev rules)
|
||||
`(("udev"
|
||||
,(file-union "udev"
|
||||
`(("udev.conf" ,udev.conf)
|
||||
("rules.d"
|
||||
,(udev-rules-union (cons* udev kvm-udev-rule
|
||||
rules)))))))))
|
||||
|
||||
(define udev-service-type
|
||||
(service-type (name 'udev)
|
||||
|
|
@ -2243,11 +2242,11 @@ (define udev-service-type
|
|||
(service-extension etc-service-type udev-etc)))
|
||||
(compose concatenate) ;concatenate the list of rules
|
||||
(extend (lambda (config rules)
|
||||
(match config
|
||||
(($ <udev-configuration> udev initial-rules)
|
||||
(udev-configuration
|
||||
(udev udev)
|
||||
(rules (append initial-rules rules)))))))
|
||||
(let ((initial-rules
|
||||
(udev-configuration-rules config)))
|
||||
(udev-configuration
|
||||
(inherit config)
|
||||
(rules (append initial-rules rules))))))
|
||||
(default-value (udev-configuration))
|
||||
(description
|
||||
"Run @command{udev}, which populates the @file{/dev}
|
||||
|
|
@ -2385,23 +2384,23 @@ (define-record-type* <gpm-configuration>
|
|||
(options gpm-configuration-options ;list of strings
|
||||
(default %default-gpm-options)))
|
||||
|
||||
(define gpm-shepherd-service
|
||||
(match-lambda
|
||||
(($ <gpm-configuration> gpm options)
|
||||
(list (shepherd-service
|
||||
(requirement '(udev))
|
||||
(provision '(gpm))
|
||||
;; 'gpm' runs in the background and sets a PID file.
|
||||
;; Note that it requires running as "root".
|
||||
(start #~(make-forkexec-constructor
|
||||
(list #$(file-append gpm "/sbin/gpm")
|
||||
#$@options)
|
||||
#:pid-file "/var/run/gpm.pid"
|
||||
#:pid-file-timeout 3))
|
||||
(stop #~(lambda (_)
|
||||
;; Return #f if successfully stopped.
|
||||
(not (zero? (system* #$(file-append gpm "/sbin/gpm")
|
||||
"-k"))))))))))
|
||||
(define (gpm-shepherd-service config)
|
||||
(match-record config <gpm-configuration>
|
||||
(gpm options)
|
||||
(list (shepherd-service
|
||||
(requirement '(udev))
|
||||
(provision '(gpm))
|
||||
;; 'gpm' runs in the background and sets a PID file.
|
||||
;; Note that it requires running as "root".
|
||||
(start #~(make-forkexec-constructor
|
||||
(list #$(file-append gpm "/sbin/gpm")
|
||||
#$@options)
|
||||
#:pid-file "/var/run/gpm.pid"
|
||||
#:pid-file-timeout 3))
|
||||
(stop #~(lambda (_)
|
||||
;; Return #f if successfully stopped.
|
||||
(not (zero? (system* #$(file-append gpm "/sbin/gpm")
|
||||
"-k")))))))))
|
||||
|
||||
(define gpm-service-type
|
||||
(service-type (name 'gpm)
|
||||
|
|
@ -2654,32 +2653,64 @@ (define (network-tear-down/hurd config)
|
|||
"/servers/socket/2")
|
||||
#f))))
|
||||
|
||||
(define network-set-up/linux
|
||||
(match-lambda
|
||||
(($ <static-networking> addresses links routes)
|
||||
(scheme-file "set-up-network"
|
||||
(with-extensions (list guile-netlink)
|
||||
#~(begin
|
||||
(use-modules (ip addr) (ip link) (ip route))
|
||||
(define (network-set-up/linux config)
|
||||
(match-record config <static-networking>
|
||||
(addresses links routes)
|
||||
(scheme-file "set-up-network"
|
||||
(with-extensions (list guile-netlink)
|
||||
#~(begin
|
||||
(use-modules (ip addr) (ip link) (ip route))
|
||||
|
||||
#$@(map (lambda (address)
|
||||
#~(begin
|
||||
(addr-add #$(network-address-device address)
|
||||
#$(network-address-value address)
|
||||
#:ipv6?
|
||||
#$(network-address-ipv6? address))
|
||||
;; FIXME: loopback?
|
||||
(link-set #$(network-address-device address)
|
||||
#:multicast-on #t
|
||||
#:up #t)))
|
||||
addresses)
|
||||
#$@(map (match-lambda
|
||||
(($ <network-link> name type arguments)
|
||||
#~(link-add #$name #$type
|
||||
#:type-args '#$arguments)))
|
||||
links)
|
||||
#$@(map (lambda (route)
|
||||
#~(route-add #$(network-route-destination route)
|
||||
#$@(map (lambda (address)
|
||||
#~(begin
|
||||
(addr-add #$(network-address-device address)
|
||||
#$(network-address-value address)
|
||||
#:ipv6?
|
||||
#$(network-address-ipv6? address))
|
||||
;; FIXME: loopback?
|
||||
(link-set #$(network-address-device address)
|
||||
#:multicast-on #t
|
||||
#:up #t)))
|
||||
addresses)
|
||||
#$@(map (match-lambda
|
||||
(($ <network-link> name type arguments)
|
||||
#~(link-add #$name #$type
|
||||
#:type-args '#$arguments)))
|
||||
links)
|
||||
#$@(map (lambda (route)
|
||||
#~(route-add #$(network-route-destination route)
|
||||
#:device
|
||||
#$(network-route-device route)
|
||||
#:ipv6?
|
||||
#$(network-route-ipv6? route)
|
||||
#:via
|
||||
#$(network-route-gateway route)
|
||||
#:src
|
||||
#$(network-route-source route)))
|
||||
routes)
|
||||
#t)))))
|
||||
|
||||
(define (network-tear-down/linux config)
|
||||
(match-record config <static-networking>
|
||||
(addresses links routes)
|
||||
(scheme-file "tear-down-network"
|
||||
(with-extensions (list guile-netlink)
|
||||
#~(begin
|
||||
(use-modules (ip addr) (ip link) (ip route)
|
||||
(netlink error)
|
||||
(srfi srfi-34))
|
||||
|
||||
(define-syntax-rule (false-if-netlink-error exp)
|
||||
(guard (c ((netlink-error? c) #f))
|
||||
exp))
|
||||
|
||||
;; Wrap calls in 'false-if-netlink-error' so this
|
||||
;; script goes as far as possible undoing the effects
|
||||
;; of "set-up-network".
|
||||
|
||||
#$@(map (lambda (route)
|
||||
#~(false-if-netlink-error
|
||||
(route-del #$(network-route-destination route)
|
||||
#:device
|
||||
#$(network-route-device route)
|
||||
#:ipv6?
|
||||
|
|
@ -2687,80 +2718,47 @@ (define network-set-up/linux
|
|||
#:via
|
||||
#$(network-route-gateway route)
|
||||
#:src
|
||||
#$(network-route-source route)))
|
||||
routes)
|
||||
#t))))))
|
||||
|
||||
(define network-tear-down/linux
|
||||
(match-lambda
|
||||
(($ <static-networking> addresses links routes)
|
||||
(scheme-file "tear-down-network"
|
||||
(with-extensions (list guile-netlink)
|
||||
#~(begin
|
||||
(use-modules (ip addr) (ip link) (ip route)
|
||||
(netlink error)
|
||||
(srfi srfi-34))
|
||||
|
||||
(define-syntax-rule (false-if-netlink-error exp)
|
||||
(guard (c ((netlink-error? c) #f))
|
||||
exp))
|
||||
|
||||
;; Wrap calls in 'false-if-netlink-error' so this
|
||||
;; script goes as far as possible undoing the effects
|
||||
;; of "set-up-network".
|
||||
|
||||
#$@(map (lambda (route)
|
||||
#$(network-route-source route))))
|
||||
routes)
|
||||
#$@(map (match-lambda
|
||||
(($ <network-link> name type arguments)
|
||||
#~(false-if-netlink-error
|
||||
(route-del #$(network-route-destination route)
|
||||
#:device
|
||||
#$(network-route-device route)
|
||||
#:ipv6?
|
||||
#$(network-route-ipv6? route)
|
||||
#:via
|
||||
#$(network-route-gateway route)
|
||||
#:src
|
||||
#$(network-route-source route))))
|
||||
routes)
|
||||
#$@(map (match-lambda
|
||||
(($ <network-link> name type arguments)
|
||||
#~(false-if-netlink-error
|
||||
(link-del #$name))))
|
||||
links)
|
||||
#$@(map (lambda (address)
|
||||
#~(false-if-netlink-error
|
||||
(addr-del #$(network-address-device
|
||||
address)
|
||||
#$(network-address-value address)
|
||||
#:ipv6?
|
||||
#$(network-address-ipv6? address))))
|
||||
addresses)
|
||||
#f))))))
|
||||
(link-del #$name))))
|
||||
links)
|
||||
#$@(map (lambda (address)
|
||||
#~(false-if-netlink-error
|
||||
(addr-del #$(network-address-device
|
||||
address)
|
||||
#$(network-address-value address)
|
||||
#:ipv6?
|
||||
#$(network-address-ipv6? address))))
|
||||
addresses)
|
||||
#f)))))
|
||||
|
||||
(define (static-networking-shepherd-service config)
|
||||
(match config
|
||||
(($ <static-networking> addresses links routes
|
||||
provision requirement name-servers)
|
||||
(let ((loopback? (and provision (memq 'loopback provision))))
|
||||
(shepherd-service
|
||||
(match-record config <static-networking>
|
||||
(addresses links routes provision requirement name-servers)
|
||||
(let ((loopback? (and provision (memq 'loopback provision))))
|
||||
(shepherd-service
|
||||
|
||||
(documentation
|
||||
"Bring up the networking interface using a static IP address.")
|
||||
(requirement requirement)
|
||||
(provision provision)
|
||||
(documentation
|
||||
"Bring up the networking interface using a static IP address.")
|
||||
(requirement requirement)
|
||||
(provision provision)
|
||||
|
||||
(start #~(lambda _
|
||||
;; Return #t if successfully started.
|
||||
(load #$(let-system (system target)
|
||||
(if (string-contains (or target system) "-linux")
|
||||
(network-set-up/linux config)
|
||||
(network-set-up/hurd config))))))
|
||||
(stop #~(lambda _
|
||||
;; Return #f is successfully stopped.
|
||||
(start #~(lambda _
|
||||
;; Return #t if successfully started.
|
||||
(load #$(let-system (system target)
|
||||
(if (string-contains (or target system) "-linux")
|
||||
(network-tear-down/linux config)
|
||||
(network-tear-down/hurd config))))))
|
||||
(respawn? #f))))))
|
||||
(network-set-up/linux config)
|
||||
(network-set-up/hurd config))))))
|
||||
(stop #~(lambda _
|
||||
;; Return #f is successfully stopped.
|
||||
(load #$(let-system (system target)
|
||||
(if (string-contains (or target system) "-linux")
|
||||
(network-tear-down/linux config)
|
||||
(network-tear-down/hurd config))))))
|
||||
(respawn? #f)))))
|
||||
|
||||
(define (static-networking-shepherd-services networks)
|
||||
(map static-networking-shepherd-service networks))
|
||||
|
|
@ -2873,33 +2871,33 @@ (define-record-type* <greetd-agreety-session>
|
|||
(extra-env greetd-agreety-extra-env (default '()))
|
||||
(xdg-env? greetd-agreety-xdg-env? (default #t)))
|
||||
|
||||
(define greetd-agreety-tty-session-command
|
||||
(match-lambda
|
||||
(($ <greetd-agreety-session> _ command args extra-env)
|
||||
(program-file
|
||||
"agreety-tty-session-command"
|
||||
#~(begin
|
||||
(use-modules (ice-9 match))
|
||||
(for-each (match-lambda ((var . val) (setenv var val)))
|
||||
(quote (#$@extra-env)))
|
||||
(apply execl #$command #$command (list #$@args)))))))
|
||||
(define (greetd-agreety-tty-session-command config)
|
||||
(match-record config <greetd-agreety-session>
|
||||
(command command-args extra-env)
|
||||
(program-file
|
||||
"agreety-tty-session-command"
|
||||
#~(begin
|
||||
(use-modules (ice-9 match))
|
||||
(for-each (match-lambda ((var . val) (setenv var val)))
|
||||
(quote (#$@extra-env)))
|
||||
(apply execl #$command #$command (list #$@command-args))))))
|
||||
|
||||
(define greetd-agreety-tty-xdg-session-command
|
||||
(match-lambda
|
||||
(($ <greetd-agreety-session> _ command args extra-env)
|
||||
(program-file
|
||||
"agreety-tty-xdg-session-command"
|
||||
#~(begin
|
||||
(use-modules (ice-9 match))
|
||||
(let*
|
||||
((username (getenv "USER"))
|
||||
(useruid (passwd:uid (getpwuid username)))
|
||||
(useruid (number->string useruid)))
|
||||
(setenv "XDG_SESSION_TYPE" "tty")
|
||||
(setenv "XDG_RUNTIME_DIR" (string-append "/run/user/" useruid)))
|
||||
(for-each (match-lambda ((var . val) (setenv var val)))
|
||||
(quote (#$@extra-env)))
|
||||
(apply execl #$command #$command (list #$@args)))))))
|
||||
(define (greetd-agreety-tty-xdg-session-command config)
|
||||
(match-record config <greetd-agreety-session>
|
||||
(command command-args extra-env)
|
||||
(program-file
|
||||
"agreety-tty-xdg-session-command"
|
||||
#~(begin
|
||||
(use-modules (ice-9 match))
|
||||
(let*
|
||||
((username (getenv "USER"))
|
||||
(useruid (passwd:uid (getpwuid username)))
|
||||
(useruid (number->string useruid)))
|
||||
(setenv "XDG_SESSION_TYPE" "tty")
|
||||
(setenv "XDG_RUNTIME_DIR" (string-append "/run/user/" useruid)))
|
||||
(for-each (match-lambda ((var . val) (setenv var val)))
|
||||
(quote (#$@extra-env)))
|
||||
(apply execl #$command #$command (list #$@command-args))))))
|
||||
|
||||
(define-gexp-compiler (greetd-agreety-session-compiler
|
||||
(session <greetd-agreety-session>)
|
||||
|
|
|
|||
Loading…
Reference in a new issue