summaryrefslogtreecommitdiff
path: root/gnu
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2022-11-19 17:54:26 +0100
committerLudovic Courtès <ludo@gnu.org>2022-12-08 13:21:53 +0100
commit156a8810019dd5b8d19f2026be80f199f8e40015 (patch)
tree670073cf034d608698055d3356766615bd3cc4bb /gnu
parent93d37985da59fbd5a42c0d868dc3616b0f8d05cc (diff)
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.
Diffstat (limited to 'gnu')
-rw-r--r--gnu/services/base.scm922
1 files changed, 460 insertions, 462 deletions
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index d99548573d1..370696a55e1 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -977,148 +977,148 @@ to use as the tty. This is primarily useful for headless systems."
977 ((device-name _ ...) 977 ((device-name _ ...)
978 device-name)))))))) 978 device-name))))))))
979 979
980(define agetty-shepherd-service 980(define (agetty-shepherd-service config)
981 (match-lambda 981 (match-record config <agetty-configuration>
982 (($ <agetty-configuration> agetty tty term baud-rate auto-login 982 (agetty tty term baud-rate auto-login
983 login-program login-pause? eight-bits? no-reset? remote? flow-control? 983 login-program login-pause? eight-bits? no-reset? remote? flow-control?
984 host no-issue? init-string no-clear? local-line extract-baud? 984 host no-issue? init-string no-clear? local-line extract-baud?
985 skip-login? no-newline? login-options chroot hangup? keep-baud? timeout 985 skip-login? no-newline? login-options chroot hangup? keep-baud? timeout
986 detect-case? wait-cr? no-hints? no-hostname? long-hostname? 986 detect-case? wait-cr? no-hints? no-hostname? long-hostname?
987 erase-characters kill-characters chdir delay nice extra-options 987 erase-characters kill-characters chdir delay nice extra-options
988 shepherd-requirement) 988 shepherd-requirement)
989 (list 989 (list
990 (shepherd-service 990 (shepherd-service
991 (documentation "Run agetty on a tty.") 991 (documentation "Run agetty on a tty.")
992 (provision (list (symbol-append 'term- (string->symbol (or tty "console"))))) 992 (provision (list (symbol-append 'term- (string->symbol (or tty "console")))))
993 993
994 ;; Since the login prompt shows the host name, wait for the 'host-name' 994 ;; Since the login prompt shows the host name, wait for the 'host-name'
995 ;; service to be done. Also wait for udev essentially so that the tty 995 ;; service to be done. Also wait for udev essentially so that the tty
996 ;; text is not lost in the middle of kernel messages (see also 996 ;; text is not lost in the middle of kernel messages (see also
997 ;; mingetty-shepherd-service). 997 ;; mingetty-shepherd-service).
998 (requirement (cons* 'user-processes 'host-name 'udev 998 (requirement (cons* 'user-processes 'host-name 'udev
999 shepherd-requirement)) 999 shepherd-requirement))
1000 1000
1001 (modules '((ice-9 match) (gnu build linux-boot))) 1001 (modules '((ice-9 match) (gnu build linux-boot)))
1002 (start 1002 (start
1003 (with-imported-modules (source-module-closure 1003 (with-imported-modules (source-module-closure
1004 '((gnu build linux-boot))) 1004 '((gnu build linux-boot)))
1005 #~(lambda args 1005 #~(lambda args
1006 (let ((defaulted-tty #$(or tty (default-serial-port)))) 1006 (let ((defaulted-tty #$(or tty (default-serial-port))))
1007 (apply 1007 (apply
1008 (if defaulted-tty 1008 (if defaulted-tty
1009 (make-forkexec-constructor 1009 (make-forkexec-constructor
1010 (list #$(file-append util-linux "/sbin/agetty") 1010 (list #$(file-append util-linux "/sbin/agetty")
1011 #$@extra-options 1011 #$@extra-options
1012 #$@(if eight-bits? 1012 #$@(if eight-bits?
1013 #~("--8bits") 1013 #~("--8bits")
1014 #~()) 1014 #~())
1015 #$@(if no-reset? 1015 #$@(if no-reset?
1016 #~("--noreset") 1016 #~("--noreset")
1017 #~()) 1017 #~())
1018 #$@(if remote? 1018 #$@(if remote?
1019 #~("--remote") 1019 #~("--remote")
1020 #~()) 1020 #~())
1021 #$@(if flow-control? 1021 #$@(if flow-control?
1022 #~("--flow-control") 1022 #~("--flow-control")
1023 #~()) 1023 #~())
1024 #$@(if host 1024 #$@(if host
1025 #~("--host" #$host) 1025 #~("--host" #$host)
1026 #~()) 1026 #~())
1027 #$@(if no-issue? 1027 #$@(if no-issue?
1028 #~("--noissue") 1028 #~("--noissue")
1029 #~()) 1029 #~())
1030 #$@(if init-string 1030 #$@(if init-string
1031 #~("--init-string" #$init-string) 1031 #~("--init-string" #$init-string)
1032 #~()) 1032 #~())
1033 #$@(if no-clear? 1033 #$@(if no-clear?
1034 #~("--noclear") 1034 #~("--noclear")
1035 #~()) 1035 #~())
1036;;; FIXME This doesn't work as expected. According to agetty(8), if this option 1036;;; FIXME This doesn't work as expected. According to agetty(8), if this option
1037;;; is not passed, then the default is 'auto'. However, in my tests, when that 1037;;; is not passed, then the default is 'auto'. However, in my tests, when that
1038;;; option is selected, agetty never presents the login prompt, and the 1038;;; option is selected, agetty never presents the login prompt, and the
1039;;; term-ttyS0 service respawns every few seconds. 1039;;; term-ttyS0 service respawns every few seconds.
1040 #$@(if local-line 1040 #$@(if local-line
1041 #~(#$(match local-line 1041 #~(#$(match local-line
1042 ('auto "--local-line=auto") 1042 ('auto "--local-line=auto")
1043 ('always "--local-line=always") 1043 ('always "--local-line=always")
1044 ('never "-local-line=never"))) 1044 ('never "-local-line=never")))
1045 #~()) 1045 #~())
1046 #$@(if tty 1046 #$@(if tty
1047 #~() 1047 #~()
1048 #~("--keep-baud")) 1048 #~("--keep-baud"))
1049 #$@(if extract-baud? 1049 #$@(if extract-baud?
1050 #~("--extract-baud") 1050 #~("--extract-baud")
1051 #~()) 1051 #~())
1052 #$@(if skip-login? 1052 #$@(if skip-login?
1053 #~("--skip-login") 1053 #~("--skip-login")
1054 #~()) 1054 #~())
1055 #$@(if no-newline? 1055 #$@(if no-newline?
1056 #~("--nonewline") 1056 #~("--nonewline")
1057 #~()) 1057 #~())
1058 #$@(if login-options 1058 #$@(if login-options
1059 #~("--login-options" #$login-options) 1059 #~("--login-options" #$login-options)
1060 #~()) 1060 #~())
1061 #$@(if chroot 1061 #$@(if chroot
1062 #~("--chroot" #$chroot) 1062 #~("--chroot" #$chroot)
1063 #~()) 1063 #~())
1064 #$@(if hangup? 1064 #$@(if hangup?
1065 #~("--hangup") 1065 #~("--hangup")
1066 #~()) 1066 #~())
1067 #$@(if keep-baud? 1067 #$@(if keep-baud?
1068 #~("--keep-baud") 1068 #~("--keep-baud")
1069 #~()) 1069 #~())
1070 #$@(if timeout 1070 #$@(if timeout
1071 #~("--timeout" #$(number->string timeout)) 1071 #~("--timeout" #$(number->string timeout))
1072 #~()) 1072 #~())
1073 #$@(if detect-case? 1073 #$@(if detect-case?
1074 #~("--detect-case") 1074 #~("--detect-case")
1075 #~()) 1075 #~())
1076 #$@(if wait-cr? 1076 #$@(if wait-cr?
1077 #~("--wait-cr") 1077 #~("--wait-cr")
1078 #~()) 1078 #~())
1079 #$@(if no-hints? 1079 #$@(if no-hints?
1080 #~("--nohints?") 1080 #~("--nohints?")
1081 #~()) 1081 #~())
1082 #$@(if no-hostname? 1082 #$@(if no-hostname?
1083 #~("--nohostname") 1083 #~("--nohostname")
1084 #~()) 1084 #~())
1085 #$@(if long-hostname? 1085 #$@(if long-hostname?
1086 #~("--long-hostname") 1086 #~("--long-hostname")
1087 #~()) 1087 #~())
1088 #$@(if erase-characters 1088 #$@(if erase-characters
1089 #~("--erase-chars" #$erase-characters) 1089 #~("--erase-chars" #$erase-characters)
1090 #~()) 1090 #~())
1091 #$@(if kill-characters 1091 #$@(if kill-characters
1092 #~("--kill-chars" #$kill-characters) 1092 #~("--kill-chars" #$kill-characters)
1093 #~()) 1093 #~())
1094 #$@(if chdir 1094 #$@(if chdir
1095 #~("--chdir" #$chdir) 1095 #~("--chdir" #$chdir)
1096 #~()) 1096 #~())
1097 #$@(if delay 1097 #$@(if delay
1098 #~("--delay" #$(number->string delay)) 1098 #~("--delay" #$(number->string delay))
1099 #~()) 1099 #~())
1100 #$@(if nice 1100 #$@(if nice
1101 #~("--nice" #$(number->string nice)) 1101 #~("--nice" #$(number->string nice))
1102 #~()) 1102 #~())
1103 #$@(if auto-login 1103 #$@(if auto-login
1104 (list "--autologin" auto-login) 1104 (list "--autologin" auto-login)
1105 '()) 1105 '())
1106 #$@(if login-program 1106 #$@(if login-program
1107 #~("--login-program" #$login-program) 1107 #~("--login-program" #$login-program)
1108 #~()) 1108 #~())
1109 #$@(if login-pause? 1109 #$@(if login-pause?
1110 #~("--login-pause") 1110 #~("--login-pause")
1111 #~()) 1111 #~())
1112 defaulted-tty 1112 defaulted-tty
1113 #$@(if baud-rate 1113 #$@(if baud-rate
1114 #~(#$baud-rate) 1114 #~(#$baud-rate)
1115 #~()) 1115 #~())
1116 #$@(if term 1116 #$@(if term
1117 #~(#$term) 1117 #~(#$term)
1118 #~()))) 1118 #~())))
1119 (const #f)) ; never start. 1119 (const #f)) ; never start.
1120 args))))) 1120 args)))))
1121 (stop #~(make-kill-destructor))))))) 1121 (stop #~(make-kill-destructor))))))
1122 1122
1123(define agetty-service-type 1123(define agetty-service-type
1124 (service-type (name 'agetty) 1124 (service-type (name 'agetty)
@@ -1148,42 +1148,42 @@ the tty to run, among other things."
1148 (clear-on-logout? mingetty-clear-on-logout? ;Boolean 1148 (clear-on-logout? mingetty-clear-on-logout? ;Boolean
1149 (default #t))) 1149 (default #t)))
1150 1150
1151(define mingetty-shepherd-service 1151(define (mingetty-shepherd-service config)
1152 (match-lambda 1152 (match-record config <mingetty-configuration>
1153 (($ <mingetty-configuration> mingetty tty auto-login login-program 1153 (mingetty tty auto-login login-program
1154 login-pause? clear-on-logout?) 1154 login-pause? clear-on-logout?)
1155 (list 1155 (list
1156 (shepherd-service 1156 (shepherd-service
1157 (documentation "Run mingetty on an tty.") 1157 (documentation "Run mingetty on an tty.")
1158 (provision (list (symbol-append 'term- (string->symbol tty)))) 1158 (provision (list (symbol-append 'term- (string->symbol tty))))
1159 1159
1160 ;; Since the login prompt shows the host name, wait for the 'host-name' 1160 ;; Since the login prompt shows the host name, wait for the 'host-name'
1161 ;; service to be done. Also wait for udev essentially so that the tty 1161 ;; service to be done. Also wait for udev essentially so that the tty
1162 ;; text is not lost in the middle of kernel messages (XXX). 1162 ;; text is not lost in the middle of kernel messages (XXX).
1163 (requirement '(user-processes host-name udev virtual-terminal)) 1163 (requirement '(user-processes host-name udev virtual-terminal))
1164 1164
1165 (start #~(make-forkexec-constructor 1165 (start #~(make-forkexec-constructor
1166 (list #$(file-append mingetty "/sbin/mingetty") 1166 (list #$(file-append mingetty "/sbin/mingetty")
1167 1167
1168 ;; Avoiding 'vhangup' allows us to avoid 'setfont' 1168 ;; Avoiding 'vhangup' allows us to avoid 'setfont'
1169 ;; errors down the path where various ioctls get 1169 ;; errors down the path where various ioctls get
1170 ;; EIO--see 'hung_up_tty_ioctl' in driver/tty/tty_io.c 1170 ;; EIO--see 'hung_up_tty_ioctl' in driver/tty/tty_io.c
1171 ;; in Linux. 1171 ;; in Linux.
1172 "--nohangup" #$tty 1172 "--nohangup" #$tty
1173 1173
1174 #$@(if clear-on-logout? 1174 #$@(if clear-on-logout?
1175 #~() 1175 #~()
1176 #~("--noclear")) 1176 #~("--noclear"))
1177 #$@(if auto-login 1177 #$@(if auto-login
1178 #~("--autologin" #$auto-login) 1178 #~("--autologin" #$auto-login)
1179 #~()) 1179 #~())
1180 #$@(if login-program 1180 #$@(if login-program
1181 #~("--loginprog" #$login-program) 1181 #~("--loginprog" #$login-program)
1182 #~()) 1182 #~())
1183 #$@(if login-pause? 1183 #$@(if login-pause?
1184 #~("--loginpause") 1184 #~("--loginpause")
1185 #~())))) 1185 #~()))))
1186 (stop #~(make-kill-destructor))))))) 1186 (stop #~(make-kill-destructor))))))
1187 1187
1188(define mingetty-service-type 1188(define mingetty-service-type
1189 (service-type (name 'mingetty) 1189 (service-type (name 'mingetty)
@@ -1260,46 +1260,47 @@ the tty to run, among other things."
1260(define (nscd.conf-file config) 1260(define (nscd.conf-file config)
1261 "Return the @file{nscd.conf} configuration file for @var{config}, an 1261 "Return the @file{nscd.conf} configuration file for @var{config}, an
1262@code{<nscd-configuration>} object." 1262@code{<nscd-configuration>} object."
1263 (define cache->config 1263 (define (cache->config cache)
1264 (match-lambda 1264 (match-record cache <nscd-cache>
1265 (($ <nscd-cache> (= symbol->string database) 1265 (database positive-time-to-live negative-time-to-live
1266 positive-ttl negative-ttl size check-files? 1266 suggested-size check-files?
1267 persistent? shared? max-size propagate?) 1267 persistent? shared? max-database-size auto-propagate?)
1268 (string-append "\nenable-cache\t" database "\tyes\n" 1268 (let ((database (symbol->string database)))
1269 1269 (string-append "\nenable-cache\t" database "\tyes\n"
1270 "positive-time-to-live\t" database "\t" 1270
1271 (number->string positive-ttl) "\n" 1271 "positive-time-to-live\t" database "\t"
1272 "negative-time-to-live\t" database "\t" 1272 (number->string positive-time-to-live) "\n"
1273 (number->string negative-ttl) "\n" 1273 "negative-time-to-live\t" database "\t"
1274 "suggested-size\t" database "\t" 1274 (number->string negative-time-to-live) "\n"
1275 (number->string size) "\n" 1275 "suggested-size\t" database "\t"
1276 "check-files\t" database "\t" 1276 (number->string suggested-size) "\n"
1277 (if check-files? "yes\n" "no\n") 1277 "check-files\t" database "\t"
1278 "persistent\t" database "\t" 1278 (if check-files? "yes\n" "no\n")
1279 (if persistent? "yes\n" "no\n") 1279 "persistent\t" database "\t"
1280 "shared\t" database "\t" 1280 (if persistent? "yes\n" "no\n")
1281 (if shared? "yes\n" "no\n") 1281 "shared\t" database "\t"
1282 "max-db-size\t" database "\t" 1282 (if shared? "yes\n" "no\n")
1283 (number->string max-size) "\n" 1283 "max-db-size\t" database "\t"
1284 "auto-propagate\t" database "\t" 1284 (number->string max-database-size) "\n"
1285 (if propagate? "yes\n" "no\n"))))) 1285 "auto-propagate\t" database "\t"
1286 1286 (if auto-propagate? "yes\n" "no\n")))))
1287 (match config 1287
1288 (($ <nscd-configuration> log-file debug-level caches) 1288 (match-record config <nscd-configuration>
1289 (plain-file "nscd.conf" 1289 (log-file debug-level caches)
1290 (string-append "\ 1290 (plain-file "nscd.conf"
1291 (string-append "\
1291# Configuration of libc's name service cache daemon (nscd).\n\n" 1292# Configuration of libc's name service cache daemon (nscd).\n\n"
1292 (if log-file 1293 (if log-file
1293 (string-append "logfile\t" log-file) 1294 (string-append "logfile\t" log-file)
1294 "") 1295 "")
1295 "\n" 1296 "\n"
1296 (if debug-level 1297 (if debug-level
1297 (string-append "debug-level\t" 1298 (string-append "debug-level\t"
1298 (number->string debug-level)) 1299 (number->string debug-level))
1299 "") 1300 "")
1300 "\n" 1301 "\n"
1301 (string-concatenate 1302 (string-concatenate
1302 (map cache->config caches))))))) 1303 (map cache->config caches))))))
1303 1304
1304(define (nscd-action-procedure nscd config option) 1305(define (nscd-action-procedure nscd config option)
1305 ;; XXX: This is duplicated from mcron; factorize. 1306 ;; XXX: This is duplicated from mcron; factorize.
@@ -1797,17 +1798,15 @@ proxy of 'guix-daemon'...~%")
1797 1798
1798(define (guix-accounts config) 1799(define (guix-accounts config)
1799 "Return the user accounts and user groups for CONFIG." 1800 "Return the user accounts and user groups for CONFIG."
1800 (match config 1801 (cons (user-group
1801 (($ <guix-configuration> _ build-group build-accounts) 1802 (name (guix-configuration-build-group config))
1802 (cons (user-group 1803 (system? #t)
1803 (name build-group) 1804
1804 (system? #t) 1805 ;; Use a fixed GID so that we can create the store with the right
1805 1806 ;; owner.
1806 ;; Use a fixed GID so that we can create the store with the right 1807 (id 30000))
1807 ;; owner. 1808 (guix-build-accounts (guix-configuration-build-accounts config)
1808 (id 30000)) 1809 #:group (guix-configuration-build-group config))))
1809 (guix-build-accounts build-accounts
1810 #:group build-group)))))
1811 1810
1812(define (guix-activation config) 1811(define (guix-activation config)
1813 "Return the activation gexp for CONFIG." 1812 "Return the activation gexp for CONFIG."
@@ -2130,95 +2129,94 @@ item of @var{packages}."
2130 (udev-rule "90-kvm.rules" 2129 (udev-rule "90-kvm.rules"
2131 "KERNEL==\"kvm\", GROUP=\"kvm\", MODE=\"0660\"\n")) 2130 "KERNEL==\"kvm\", GROUP=\"kvm\", MODE=\"0660\"\n"))
2132 2131
2133(define udev-shepherd-service 2132(define (udev-shepherd-service config)
2134 ;; Return a <shepherd-service> for UDEV with RULES. 2133 ;; Return a <shepherd-service> for UDEV with RULES.
2135 (match-lambda 2134 (let ((udev (udev-configuration-udev config)))
2136 (($ <udev-configuration> udev) 2135 (list
2137 (list 2136 (shepherd-service
2138 (shepherd-service 2137 (provision '(udev))
2139 (provision '(udev)) 2138
2140 2139 ;; Udev needs /dev to be a 'devtmpfs' mount so that new device nodes can
2141 ;; Udev needs /dev to be a 'devtmpfs' mount so that new device nodes can 2140 ;; be added: see
2142 ;; be added: see 2141 ;; <http://www.linuxfromscratch.org/lfs/view/development/chapter07/udev.html>.
2143 ;; <http://www.linuxfromscratch.org/lfs/view/development/chapter07/udev.html>. 2142 (requirement '(root-file-system))
2144 (requirement '(root-file-system)) 2143
2145 2144 (documentation "Populate the /dev directory, dynamically.")
2146 (documentation "Populate the /dev directory, dynamically.") 2145 (start
2147 (start 2146 (with-imported-modules (source-module-closure
2148 (with-imported-modules (source-module-closure 2147 '((gnu build linux-boot)))
2149 '((gnu build linux-boot))) 2148 #~(lambda ()
2150 #~(lambda () 2149 (define udevd
2151 (define udevd 2150 ;; 'udevd' from eudev.
2152 ;; 'udevd' from eudev. 2151 #$(file-append udev "/sbin/udevd"))
2153 #$(file-append udev "/sbin/udevd")) 2152
2154 2153 (define (wait-for-udevd)
2155 (define (wait-for-udevd) 2154 ;; Wait until someone's listening on udevd's control
2156 ;; Wait until someone's listening on udevd's control 2155 ;; socket.
2157 ;; socket. 2156 (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0)))
2158 (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0))) 2157 (let try ()
2159 (let try () 2158 (catch 'system-error
2160 (catch 'system-error 2159 (lambda ()
2161 (lambda () 2160 (connect sock PF_UNIX "/run/udev/control")
2162 (connect sock PF_UNIX "/run/udev/control") 2161 (close-port sock))
2163 (close-port sock)) 2162 (lambda args
2164 (lambda args 2163 (format #t "waiting for udevd...~%")
2165 (format #t "waiting for udevd...~%") 2164 (usleep 500000)
2166 (usleep 500000) 2165 (try))))))
2167 (try)))))) 2166
2168 2167 ;; Allow udev to find the modules.
2169 ;; Allow udev to find the modules. 2168 (setenv "LINUX_MODULE_DIRECTORY"
2170 (setenv "LINUX_MODULE_DIRECTORY" 2169 "/run/booted-system/kernel/lib/modules")
2171 "/run/booted-system/kernel/lib/modules") 2170
2172 2171 (let* ((kernel-release
2173 (let* ((kernel-release 2172 (utsname:release (uname)))
2174 (utsname:release (uname))) 2173 (linux-module-directory
2175 (linux-module-directory 2174 (getenv "LINUX_MODULE_DIRECTORY"))
2176 (getenv "LINUX_MODULE_DIRECTORY")) 2175 (directory
2177 (directory 2176 (string-append linux-module-directory "/"
2178 (string-append linux-module-directory "/" 2177 kernel-release))
2179 kernel-release)) 2178 (old-umask (umask #o022)))
2180 (old-umask (umask #o022))) 2179 ;; If we're in a container, DIRECTORY might not exist,
2181 ;; If we're in a container, DIRECTORY might not exist, 2180 ;; for instance because the host runs a different
2182 ;; for instance because the host runs a different 2181 ;; kernel. In that case, skip it; we'll just miss a few
2183 ;; kernel. In that case, skip it; we'll just miss a few 2182 ;; nodes like /dev/fuse.
2184 ;; nodes like /dev/fuse. 2183 (when (file-exists? directory)
2185 (when (file-exists? directory) 2184 (make-static-device-nodes directory))
2186 (make-static-device-nodes directory)) 2185 (umask old-umask))
2187 (umask old-umask)) 2186
2188 2187 (let ((pid (fork+exec-command
2189 (let ((pid (fork+exec-command 2188 (list udevd)
2190 (list udevd) 2189 #:environment-variables
2191 #:environment-variables 2190 (cons*
2192 (cons* 2191 ;; The first one is for udev, the second one for
2193 ;; The first one is for udev, the second one for 2192 ;; eudev.
2194 ;; eudev. 2193 "UDEV_CONFIG_FILE=/etc/udev/udev.conf"
2195 "UDEV_CONFIG_FILE=/etc/udev/udev.conf" 2194 "EUDEV_RULES_DIRECTORY=/etc/udev/rules.d"
2196 "EUDEV_RULES_DIRECTORY=/etc/udev/rules.d" 2195 (string-append "LINUX_MODULE_DIRECTORY="
2197 (string-append "LINUX_MODULE_DIRECTORY=" 2196 (getenv "LINUX_MODULE_DIRECTORY"))
2198 (getenv "LINUX_MODULE_DIRECTORY")) 2197 (default-environment-variables)))))
2199 (default-environment-variables))))) 2198 ;; Wait until udevd is up and running. This appears to
2200 ;; Wait until udevd is up and running. This appears to 2199 ;; be needed so that the events triggered below are
2201 ;; be needed so that the events triggered below are 2200 ;; actually handled.
2202 ;; actually handled. 2201 (wait-for-udevd)
2203 (wait-for-udevd) 2202
2204 2203 ;; Trigger device node creation.
2205 ;; Trigger device node creation. 2204 (system* #$(file-append udev "/bin/udevadm")
2206 (system* #$(file-append udev "/bin/udevadm") 2205 "trigger" "--action=add")
2207 "trigger" "--action=add") 2206
2208 2207 ;; Wait for things to settle down.
2209 ;; Wait for things to settle down. 2208 (system* #$(file-append udev "/bin/udevadm")
2210 (system* #$(file-append udev "/bin/udevadm") 2209 "settle")
2211 "settle") 2210 pid))))
2212 pid)))) 2211 (stop #~(make-kill-destructor))
2213 (stop #~(make-kill-destructor)) 2212
2214 2213 ;; When halting the system, 'udev' is actually killed by
2215 ;; When halting the system, 'udev' is actually killed by 2214 ;; 'user-processes', i.e., before its own 'stop' method was called.
2216 ;; 'user-processes', i.e., before its own 'stop' method was called. 2215 ;; Thus, make sure it is not respawned.
2217 ;; Thus, make sure it is not respawned. 2216 (respawn? #f)
2218 (respawn? #f) 2217 ;; We need additional modules.
2219 ;; We need additional modules. 2218 (modules `((gnu build linux-boot) ;'make-static-device-nodes'
2220 (modules `((gnu build linux-boot) ;'make-static-device-nodes' 2219 ,@%default-modules))))))
2221 ,@%default-modules)))))))
2222 2220
2223(define udev.conf 2221(define udev.conf
2224 (computed-file "udev.conf" 2222 (computed-file "udev.conf"
@@ -2226,14 +2224,15 @@ item of @var{packages}."
2226 (lambda (port) 2224 (lambda (port)
2227 (format port "udev_rules=\"/etc/udev/rules.d\"~%"))))) 2225 (format port "udev_rules=\"/etc/udev/rules.d\"~%")))))
2228 2226
2229(define udev-etc 2227(define (udev-etc config)
2230 (match-lambda 2228 (match-record config <udev-configuration>
2231 (($ <udev-configuration> udev rules) 2229 (udev rules)
2232 `(("udev" 2230 `(("udev"
2233 ,(file-union 2231 ,(file-union "udev"
2234 "udev" `(("udev.conf" ,udev.conf) 2232 `(("udev.conf" ,udev.conf)
2235 ("rules.d" ,(udev-rules-union (cons* udev kvm-udev-rule 2233 ("rules.d"
2236 rules)))))))))) 2234 ,(udev-rules-union (cons* udev kvm-udev-rule
2235 rules)))))))))
2237 2236
2238(define udev-service-type 2237(define udev-service-type
2239 (service-type (name 'udev) 2238 (service-type (name 'udev)
@@ -2243,11 +2242,11 @@ item of @var{packages}."
2243 (service-extension etc-service-type udev-etc))) 2242 (service-extension etc-service-type udev-etc)))
2244 (compose concatenate) ;concatenate the list of rules 2243 (compose concatenate) ;concatenate the list of rules
2245 (extend (lambda (config rules) 2244 (extend (lambda (config rules)
2246 (match config 2245 (let ((initial-rules
2247 (($ <udev-configuration> udev initial-rules) 2246 (udev-configuration-rules config)))
2248 (udev-configuration 2247 (udev-configuration
2249 (udev udev) 2248 (inherit config)
2250 (rules (append initial-rules rules))))))) 2249 (rules (append initial-rules rules))))))
2251 (default-value (udev-configuration)) 2250 (default-value (udev-configuration))
2252 (description 2251 (description
2253 "Run @command{udev}, which populates the @file{/dev} 2252 "Run @command{udev}, which populates the @file{/dev}
@@ -2385,23 +2384,23 @@ instance."
2385 (options gpm-configuration-options ;list of strings 2384 (options gpm-configuration-options ;list of strings
2386 (default %default-gpm-options))) 2385 (default %default-gpm-options)))
2387 2386
2388(define gpm-shepherd-service 2387(define (gpm-shepherd-service config)
2389 (match-lambda 2388 (match-record config <gpm-configuration>
2390 (($ <gpm-configuration> gpm options) 2389 (gpm options)
2391 (list (shepherd-service 2390 (list (shepherd-service
2392 (requirement '(udev)) 2391 (requirement '(udev))
2393 (provision '(gpm)) 2392 (provision '(gpm))
2394 ;; 'gpm' runs in the background and sets a PID file. 2393 ;; 'gpm' runs in the background and sets a PID file.
2395 ;; Note that it requires running as "root". 2394 ;; Note that it requires running as "root".
2396 (start #~(make-forkexec-constructor 2395 (start #~(make-forkexec-constructor
2397 (list #$(file-append gpm "/sbin/gpm") 2396 (list #$(file-append gpm "/sbin/gpm")
2398 #$@options) 2397 #$@options)
2399 #:pid-file "/var/run/gpm.pid" 2398 #:pid-file "/var/run/gpm.pid"
2400 #:pid-file-timeout 3)) 2399 #:pid-file-timeout 3))
2401 (stop #~(lambda (_) 2400 (stop #~(lambda (_)
2402 ;; Return #f if successfully stopped. 2401 ;; Return #f if successfully stopped.
2403 (not (zero? (system* #$(file-append gpm "/sbin/gpm") 2402 (not (zero? (system* #$(file-append gpm "/sbin/gpm")
2404 "-k")))))))))) 2403 "-k")))))))))
2405 2404
2406(define gpm-service-type 2405(define gpm-service-type
2407 (service-type (name 'gpm) 2406 (service-type (name 'gpm)
@@ -2654,32 +2653,64 @@ to CONFIG."
2654 "/servers/socket/2") 2653 "/servers/socket/2")
2655 #f)))) 2654 #f))))
2656 2655
2657(define network-set-up/linux 2656(define (network-set-up/linux config)
2658 (match-lambda 2657 (match-record config <static-networking>
2659 (($ <static-networking> addresses links routes) 2658 (addresses links routes)
2660 (scheme-file "set-up-network" 2659 (scheme-file "set-up-network"
2661 (with-extensions (list guile-netlink) 2660 (with-extensions (list guile-netlink)
2662 #~(begin 2661 #~(begin
2663 (use-modules (ip addr) (ip link) (ip route)) 2662 (use-modules (ip addr) (ip link) (ip route))
2664 2663
2665 #$@(map (lambda (address) 2664 #$@(map (lambda (address)
2666 #~(begin 2665 #~(begin
2667 (addr-add #$(network-address-device address) 2666 (addr-add #$(network-address-device address)
2668 #$(network-address-value address) 2667 #$(network-address-value address)
2669 #:ipv6? 2668 #:ipv6?
2670 #$(network-address-ipv6? address)) 2669 #$(network-address-ipv6? address))
2671 ;; FIXME: loopback? 2670 ;; FIXME: loopback?
2672 (link-set #$(network-address-device address) 2671 (link-set #$(network-address-device address)
2673 #:multicast-on #t 2672 #:multicast-on #t
2674 #:up #t))) 2673 #:up #t)))
2675 addresses) 2674 addresses)
2676 #$@(map (match-lambda 2675 #$@(map (match-lambda
2677 (($ <network-link> name type arguments) 2676 (($ <network-link> name type arguments)
2678 #~(link-add #$name #$type 2677 #~(link-add #$name #$type
2679 #:type-args '#$arguments))) 2678 #:type-args '#$arguments)))
2680 links) 2679 links)
2681 #$@(map (lambda (route) 2680 #$@(map (lambda (route)
2682 #~(route-add #$(network-route-destination route) 2681 #~(route-add #$(network-route-destination route)
2682 #:device
2683 #$(network-route-device route)
2684 #:ipv6?
2685 #$(network-route-ipv6? route)
2686 #:via
2687 #$(network-route-gateway route)
2688 #:src
2689 #$(network-route-source route)))
2690 routes)
2691 #t)))))
2692
2693(define (network-tear-down/linux config)
2694 (match-record config <static-networking>
2695 (addresses links routes)
2696 (scheme-file "tear-down-network"
2697 (with-extensions (list guile-netlink)
2698 #~(begin
2699 (use-modules (ip addr) (ip link) (ip route)
2700 (netlink error)
2701 (srfi srfi-34))
2702
2703 (define-syntax-rule (false-if-netlink-error exp)
2704 (guard (c ((netlink-error? c) #f))
2705 exp))
2706
2707 ;; Wrap calls in 'false-if-netlink-error' so this
2708 ;; script goes as far as possible undoing the effects
2709 ;; of "set-up-network".
2710
2711 #$@(map (lambda (route)
2712 #~(false-if-netlink-error
2713 (route-del #$(network-route-destination route)
2683 #:device 2714 #:device
2684 #$(network-route-device route) 2715 #$(network-route-device route)
2685 #:ipv6? 2716 #:ipv6?
@@ -2687,80 +2718,47 @@ to CONFIG."
2687 #:via 2718 #:via
2688 #$(network-route-gateway route) 2719 #$(network-route-gateway route)
2689 #:src 2720 #:src
2690 #$(network-route-source route))) 2721 #$(network-route-source route))))
2691 routes) 2722 routes)
2692 #t)))))) 2723 #$@(map (match-lambda
2693 2724 (($ <network-link> name type arguments)
2694(define network-tear-down/linux
2695 (match-lambda
2696 (($ <static-networking> addresses links routes)
2697 (scheme-file "tear-down-network"
2698 (with-extensions (list guile-netlink)
2699 #~(begin
2700 (use-modules (ip addr) (ip link) (ip route)
2701 (netlink error)
2702 (srfi srfi-34))
2703
2704 (define-syntax-rule (false-if-netlink-error exp)
2705 (guard (c ((netlink-error? c) #f))
2706 exp))
2707
2708 ;; Wrap calls in 'false-if-netlink-error' so this
2709 ;; script goes as far as possible undoing the effects
2710 ;; of "set-up-network".
2711
2712 #$@(map (lambda (route)
2713 #~(false-if-netlink-error
2714 (route-del #$(network-route-destination route)
2715 #:device
2716 #$(network-route-device route)
2717 #:ipv6?
2718 #$(network-route-ipv6? route)
2719 #:via
2720 #$(network-route-gateway route)
2721 #:src
2722 #$(network-route-source route))))
2723 routes)
2724 #$@(map (match-lambda
2725 (($ <network-link> name type arguments)
2726 #~(false-if-netlink-error
2727 (link-del #$name))))
2728 links)
2729 #$@(map (lambda (address)
2730 #~(false-if-netlink-error 2725 #~(false-if-netlink-error
2731 (addr-del #$(network-address-device 2726 (link-del #$name))))
2732 address) 2727 links)
2733 #$(network-address-value address) 2728 #$@(map (lambda (address)
2734 #:ipv6? 2729 #~(false-if-netlink-error
2735 #$(network-address-ipv6? address)))) 2730 (addr-del #$(network-address-device
2736 addresses) 2731 address)
2737 #f)))))) 2732 #$(network-address-value address)
2733 #:ipv6?
2734 #$(network-address-ipv6? address))))
2735 addresses)
2736 #f)))))
2738 2737
2739(define (static-networking-shepherd-service config) 2738(define (static-networking-shepherd-service config)
2740 (match config 2739 (match-record config <static-networking>
2741 (($ <static-networking> addresses links routes 2740 (addresses links routes provision requirement name-servers)
2742 provision requirement name-servers) 2741 (let ((loopback? (and provision (memq 'loopback provision))))
2743 (let ((loopback? (and provision (memq 'loopback provision)))) 2742 (shepherd-service
2744 (shepherd-service
2745 2743
2746 (documentation 2744 (documentation
2747 "Bring up the networking interface using a static IP address.") 2745 "Bring up the networking interface using a static IP address.")
2748 (requirement requirement) 2746 (requirement requirement)
2749 (provision provision) 2747 (provision provision)
2750 2748
2751 (start #~(lambda _ 2749 (start #~(lambda _
2752 ;; Return #t if successfully started. 2750 ;; Return #t if successfully started.
2753 (load #$(let-system (system target)
2754 (if (string-contains (or target system) "-linux")
2755 (network-set-up/linux config)
2756 (network-set-up/hurd config))))))
2757 (stop #~(lambda _
2758 ;; Return #f is successfully stopped.
2759 (load #$(let-system (system target) 2751 (load #$(let-system (system target)
2760 (if (string-contains (or target system) "-linux") 2752 (if (string-contains (or target system) "-linux")
2761 (network-tear-down/linux config) 2753 (network-set-up/linux config)
2762 (network-tear-down/hurd config)))))) 2754 (network-set-up/hurd config))))))
2763 (respawn? #f)))))) 2755 (stop #~(lambda _
2756 ;; Return #f is successfully stopped.
2757 (load #$(let-system (system target)
2758 (if (string-contains (or target system) "-linux")
2759 (network-tear-down/linux config)
2760 (network-tear-down/hurd config))))))
2761 (respawn? #f)))))
2764 2762
2765(define (static-networking-shepherd-services networks) 2763(define (static-networking-shepherd-services networks)
2766 (map static-networking-shepherd-service networks)) 2764 (map static-networking-shepherd-service networks))
@@ -2873,33 +2871,33 @@ to handle."
2873 (extra-env greetd-agreety-extra-env (default '())) 2871 (extra-env greetd-agreety-extra-env (default '()))
2874 (xdg-env? greetd-agreety-xdg-env? (default #t))) 2872 (xdg-env? greetd-agreety-xdg-env? (default #t)))
2875 2873
2876(define greetd-agreety-tty-session-command 2874(define (greetd-agreety-tty-session-command config)
2877 (match-lambda 2875 (match-record config <greetd-agreety-session>
2878 (($ <greetd-agreety-session> _ command args extra-env) 2876 (command command-args extra-env)
2879 (program-file 2877 (program-file
2880 "agreety-tty-session-command" 2878 "agreety-tty-session-command"
2881 #~(begin 2879 #~(begin
2882 (use-modules (ice-9 match)) 2880 (use-modules (ice-9 match))
2883 (for-each (match-lambda ((var . val) (setenv var val))) 2881 (for-each (match-lambda ((var . val) (setenv var val)))
2884 (quote (#$@extra-env))) 2882 (quote (#$@extra-env)))
2885 (apply execl #$command #$command (list #$@args))))))) 2883 (apply execl #$command #$command (list #$@command-args))))))
2886 2884
2887(define greetd-agreety-tty-xdg-session-command 2885(define (greetd-agreety-tty-xdg-session-command config)
2888 (match-lambda 2886 (match-record config <greetd-agreety-session>
2889 (($ <greetd-agreety-session> _ command args extra-env) 2887 (command command-args extra-env)
2890 (program-file 2888 (program-file
2891 "agreety-tty-xdg-session-command" 2889 "agreety-tty-xdg-session-command"
2892 #~(begin 2890 #~(begin
2893 (use-modules (ice-9 match)) 2891 (use-modules (ice-9 match))
2894 (let* 2892 (let*
2895 ((username (getenv "USER")) 2893 ((username (getenv "USER"))
2896 (useruid (passwd:uid (getpwuid username))) 2894 (useruid (passwd:uid (getpwuid username)))
2897 (useruid (number->string useruid))) 2895 (useruid (number->string useruid)))
2898 (setenv "XDG_SESSION_TYPE" "tty") 2896 (setenv "XDG_SESSION_TYPE" "tty")
2899 (setenv "XDG_RUNTIME_DIR" (string-append "/run/user/" useruid))) 2897 (setenv "XDG_RUNTIME_DIR" (string-append "/run/user/" useruid)))
2900 (for-each (match-lambda ((var . val) (setenv var val))) 2898 (for-each (match-lambda ((var . val) (setenv var val)))
2901 (quote (#$@extra-env))) 2899 (quote (#$@extra-env)))
2902 (apply execl #$command #$command (list #$@args))))))) 2900 (apply execl #$command #$command (list #$@command-args))))))
2903 2901
2904(define-gexp-compiler (greetd-agreety-session-compiler 2902(define-gexp-compiler (greetd-agreety-session-compiler
2905 (session <greetd-agreety-session>) 2903 (session <greetd-agreety-session>)