diff options
| -rw-r--r-- | gnu/installer.scm | 3 | ||||
| -rw-r--r-- | gnu/machine/ssh.scm | 35 | ||||
| -rw-r--r-- | gnu/services.scm | 46 | ||||
| -rw-r--r-- | gnu/services/base.scm | 428 | ||||
| -rw-r--r-- | gnu/system/image.scm | 2 | ||||
| -rw-r--r-- | gnu/system/shadow.scm | 12 |
6 files changed, 255 insertions, 271 deletions
diff --git a/gnu/installer.scm b/gnu/installer.scm index 576ac90a4b..5c3192d7a6 100644 --- a/gnu/installer.scm +++ b/gnu/installer.scm @@ -342,8 +342,7 @@ selected keymap." ;; packages …), etc. modules. (with-extensions (list guile-gcrypt guile-newt guile-parted guile-bytestructures - guile-json-3 guile-git guile-zlib - guix) + guile-json-3 guile-git guix) (with-imported-modules `(,@(source-module-closure `(,@modules (gnu services herd) diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm index ee5032e281..4e31baa4b9 100644 --- a/gnu/machine/ssh.scm +++ b/gnu/machine/ssh.scm @@ -21,7 +21,6 @@ #:use-module (gnu bootloader) #:use-module (gnu machine) #:autoload (gnu packages gnupg) (guile-gcrypt) - #:autoload (gnu packages guile) (guile-zlib) #:use-module (gnu system) #:use-module (gnu system file-systems) #:use-module (gnu system uuid) @@ -249,24 +248,22 @@ not available in the initrd." '((gnu build file-systems) (gnu build linux-modules) (gnu system uuid))) - (with-extensions (list guile-zlib) - #~(begin - (use-modules (gnu build file-systems) - (gnu build linux-modules) - (gnu system uuid)) - - (define dev - #$(cond ((string? device) device) - ((uuid? device) #~(find-partition-by-uuid - (string->uuid - #$(uuid->string device)))) - ((file-system-label? device) - #~(find-partition-by-label - #$(file-system-label->string device))))) - - (missing-modules dev - '#$(operating-system-initrd-modules - (machine-operating-system machine)))))))) + #~(begin + (use-modules (gnu build file-systems) + (gnu build linux-modules) + (gnu system uuid)) + + (define dev + #$(cond ((string? device) device) + ((uuid? device) #~(find-partition-by-uuid + (string->uuid + #$(uuid->string device)))) + ((file-system-label? device) + #~(find-partition-by-label + #$(file-system-label->string device))))) + + (missing-modules dev '#$(operating-system-initrd-modules + (machine-operating-system machine))))))) (remote-let ((missing remote-exp)) (unless (null? missing) diff --git a/gnu/services.scm b/gnu/services.scm index 3e59c6401f..11ba21e824 100644 --- a/gnu/services.scm +++ b/gnu/services.scm @@ -35,7 +35,6 @@ #:use-module (guix modules) #:use-module (gnu packages base) #:use-module (gnu packages bash) - #:use-module (gnu packages guile) #:use-module (gnu packages hurd) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) @@ -586,29 +585,28 @@ ACTIVATION-SCRIPT-TYPE." (with-imported-modules (source-module-closure '((gnu build activation) (guix build utils))) - (with-extensions (list guile-zlib) - #~(begin - (use-modules (gnu build activation) - (guix build utils)) - - ;; Make sure the user accounting database exists. If - ;; it does not exist, 'setutxent' does not create it - ;; and thus there is no accounting at all. - (close-port (open-file "/var/run/utmpx" "a0")) - - ;; Same for 'wtmp', which is populated by mingetty et - ;; al. - (mkdir-p "/var/log") - (close-port (open-file "/var/log/wtmp" "a0")) - - ;; Set up /run/current-system. Among other things - ;; this sets up locales, which the activation snippets - ;; executed below may expect. - (activate-current-system) - - ;; Run the services' activation snippets. - ;; TODO: Use 'load-compiled'. - (for-each primitive-load '#$actions)))))) + #~(begin + (use-modules (gnu build activation) + (guix build utils)) + + ;; Make sure the user accounting database exists. If it + ;; does not exist, 'setutxent' does not create it and + ;; thus there is no accounting at all. + (close-port (open-file "/var/run/utmpx" "a0")) + + ;; Same for 'wtmp', which is populated by mingetty et + ;; al. + (mkdir-p "/var/log") + (close-port (open-file "/var/log/wtmp" "a0")) + + ;; Set up /run/current-system. Among other things this + ;; sets up locales, which the activation snippets + ;; executed below may expect. + (activate-current-system) + + ;; Run the services' activation snippets. + ;; TODO: Use 'load-compiled'. + (for-each primitive-load '#$actions))))) (define (gexps->activation-gexp gexps) "Return a gexp that runs the activation script containing GEXPS." diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 966e7fe024..491f35702a 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -50,7 +50,6 @@ #:select (coreutils glibc glibc-utf8-locales)) #:use-module (gnu packages package-management) #:use-module ((gnu packages gnupg) #:select (guile-gcrypt)) - #:use-module ((gnu packages guile) #:select (guile-zlib)) #:use-module (gnu packages linux) #:use-module (gnu packages terminals) #:use-module ((gnu build file-systems) @@ -837,38 +836,36 @@ the message of the day, among other things." to use as the tty. This is primarily useful for headless systems." (with-imported-modules (source-module-closure '((gnu build linux-boot))) ;for 'find-long-options' - (with-extensions (list guile-zlib) - #~(begin - ;; console=device,options - ;; device: can be tty0, ttyS0, lp0, ttyUSB0 (serial). - ;; options: BBBBPNF. P n|o|e, N number of bits, - ;; F flow control (r RTS) - (let* ((not-comma (char-set-complement (char-set #\,))) - (command (linux-command-line)) - (agetty-specs (find-long-options "agetty.tty" command)) - (console-specs - (filter (lambda (spec) - (and (string-prefix? "tty" spec) - (not (or - (string-prefix? "tty0" spec) - (string-prefix? "tty1" spec) - (string-prefix? "tty2" spec) - (string-prefix? "tty3" spec) - (string-prefix? "tty4" spec) - (string-prefix? "tty5" spec) - (string-prefix? "tty6" spec) - (string-prefix? "tty7" spec) - (string-prefix? "tty8" spec) - (string-prefix? "tty9" spec))))) - (find-long-options "console" command))) - (specs (append agetty-specs console-specs))) - (match specs - (() #f) - ((spec _ ...) - ;; Extract device name from first spec. - (match (string-tokenize spec not-comma) - ((device-name _ ...) - device-name))))))))) + #~(begin + ;; console=device,options + ;; device: can be tty0, ttyS0, lp0, ttyUSB0 (serial). + ;; options: BBBBPNF. P n|o|e, N number of bits, + ;; F flow control (r RTS) + (let* ((not-comma (char-set-complement (char-set #\,))) + (command (linux-command-line)) + (agetty-specs (find-long-options "agetty.tty" command)) + (console-specs (filter (lambda (spec) + (and (string-prefix? "tty" spec) + (not (or + (string-prefix? "tty0" spec) + (string-prefix? "tty1" spec) + (string-prefix? "tty2" spec) + (string-prefix? "tty3" spec) + (string-prefix? "tty4" spec) + (string-prefix? "tty5" spec) + (string-prefix? "tty6" spec) + (string-prefix? "tty7" spec) + (string-prefix? "tty8" spec) + (string-prefix? "tty9" spec))))) + (find-long-options "console" command))) + (specs (append agetty-specs console-specs))) + (match specs + (() #f) + ((spec _ ...) + ;; Extract device name from first spec. + (match (string-tokenize spec not-comma) + ((device-name _ ...) + device-name)))))))) (define agetty-shepherd-service (match-lambda @@ -893,124 +890,122 @@ to use as the tty. This is primarily useful for headless systems." (start (with-imported-modules (source-module-closure '((gnu build linux-boot))) - (with-extensions (list guile-zlib) - #~(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)))))) + #~(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))))))) (define agetty-service-type @@ -1944,73 +1939,70 @@ item of @var{packages}." (start (with-imported-modules (source-module-closure '((gnu build linux-boot))) - (with-extensions (list guile-zlib) - #~(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)))))) - - ;; 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 ((pid - (fork+exec-command - (list udevd) - #:environment-variables - (cons* - ;; The first one is for udev, the second one for - ;; eudev. - (string-append "UDEV_CONFIG_FILE=" #$udev.conf) - (string-append "EUDEV_RULES_DIRECTORY=" - #$(file-append - rules "/lib/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") - - ;; Wait for things to settle down. - (system* #$(file-append udev "/bin/udevadm") - "settle") - pid))))) + #~(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)))))) + + ;; 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 ((pid (fork+exec-command (list udevd) + #:environment-variables + (cons* + ;; The first one is for udev, the second one for + ;; eudev. + (string-append "UDEV_CONFIG_FILE=" #$udev.conf) + (string-append "EUDEV_RULES_DIRECTORY=" + #$(file-append + rules "/lib/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") + + ;; 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 diff --git a/gnu/system/image.scm b/gnu/system/image.scm index 19c99a3dfa..36f56e237d 100644 --- a/gnu/system/image.scm +++ b/gnu/system/image.scm @@ -141,7 +141,7 @@ (match (package-transitive-propagated-inputs package) (((labels packages) ...) packages)))) - (list guile-gcrypt guile-sqlite3 guile-zlib))) + (list guile-gcrypt guile-sqlite3))) (define-syntax-rule (with-imported-modules* gexp* ...) (with-extensions gcrypt-sqlite3&co diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm index f642d250b0..a69339bc07 100644 --- a/gnu/system/shadow.scm +++ b/gnu/system/shadow.scm @@ -34,7 +34,6 @@ #:use-module ((gnu packages admin) #:select (shadow)) #:use-module (gnu packages bash) - #:use-module (gnu packages guile) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) @@ -325,12 +324,11 @@ accounts among ACCOUNTS+GROUPS." (start (with-imported-modules (source-module-closure '((gnu build activation) (gnu system accounts))) - (with-extensions (list guile-zlib) - #~(lambda () - (activate-user-home - (map sexp->user-account - (list #$@(map user-account->gexp accounts)))) - #t)))) ;success + #~(lambda () + (activate-user-home + (map sexp->user-account + (list #$@(map user-account->gexp accounts)))) + #t))) ;success (documentation "Create user home directories.")))) (define (shells-file shells) |