aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gnu/services.scm164
-rw-r--r--gnu/services/shepherd.scm40
-rw-r--r--gnu/system.scm1
-rw-r--r--gnu/tests/base.scm27
4 files changed, 110 insertions, 122 deletions
diff --git a/gnu/services.scm b/gnu/services.scm
index 51edb4868d..49cf01a4f8 100644
--- a/gnu/services.scm
+++ b/gnu/services.scm
@@ -337,15 +337,14 @@ containing the given entries."
turn refers to everything the operating system needs: its kernel, initrd,
system profile, boot script, and so on.")))
-(define (compute-boot-script _ mexps)
- ;; Reverse MEXPS so that extensions appear in the boot script in the right
+(define (compute-boot-script _ gexps)
+ ;; Reverse GEXPS so that extensions appear in the boot script in the right
;; order. That is, user extensions would come first, and extensions added
;; by 'essential-services' (e.g., running shepherd) are guaranteed to come
;; last.
- (mlet %store-monad ((gexps (sequence %store-monad (reverse mexps))))
- (gexp->file "boot"
- ;; Clean up and activate the system, then spawn shepherd.
- #~(begin #$@gexps))))
+ (gexp->file "boot"
+ ;; Clean up and activate the system, then spawn shepherd.
+ #~(begin #$@(reverse gexps))))
(define (boot-script-entry mboot)
"Return, as a monadic value, an entry for the boot script in the system
@@ -354,9 +353,9 @@ directory."
(return `(("boot" ,boot)))))
(define boot-service-type
- ;; The service of this type is extended by being passed gexps as monadic
- ;; values. It aggregates them in a single script, as a monadic value, which
- ;; becomes its 'parameters'. It is the only service that extends nothing.
+ ;; The service of this type is extended by being passed gexps. It
+ ;; aggregates them in a single script, as a monadic value, which becomes its
+ ;; value.
(service-type (name 'boot)
(extensions
(list (service-extension system-service-type
@@ -372,48 +371,46 @@ by the initrd once the root file system is mounted.")))
(service boot-service-type #t))
(define (cleanup-gexp _)
- "Return as a monadic value a gexp to clean up /tmp and similar places upon
-boot."
- (with-monad %store-monad
- (with-imported-modules '((guix build utils))
- (return #~(begin
- (use-modules (guix build utils))
-
- ;; Clean out /tmp and /var/run.
- ;;
- ;; XXX This needs to happen before service activations, so it
- ;; has to be here, but this also implicitly assumes that /tmp
- ;; and /var/run are on the root partition.
- (letrec-syntax ((fail-safe (syntax-rules ()
- ((_ exp rest ...)
- (begin
- (catch 'system-error
- (lambda () exp)
- (const #f))
- (fail-safe rest ...)))
- ((_)
- #t))))
- ;; Ignore I/O errors so the system can boot.
- (fail-safe
- ;; Remove stale Shadow lock files as they would lead to
- ;; failures of 'useradd' & co.
- (delete-file "/etc/group.lock")
- (delete-file "/etc/passwd.lock")
- (delete-file "/etc/.pwd.lock") ;from 'lckpwdf'
-
- ;; Force file names to be decoded as UTF-8. See
- ;; <https://bugs.gnu.org/26353>.
- (setenv "GUIX_LOCPATH"
- #+(file-append glibc-utf8-locales "/lib/locale"))
- (setlocale LC_CTYPE "en_US.utf8")
- (delete-file-recursively "/tmp")
- (delete-file-recursively "/var/run")
-
- (mkdir "/tmp")
- (chmod "/tmp" #o1777)
- (mkdir "/var/run")
- (chmod "/var/run" #o755)
- (delete-file-recursively "/run/udev/watch.old"))))))))
+ "Return a gexp to clean up /tmp and similar places upon boot."
+ (with-imported-modules '((guix build utils))
+ #~(begin
+ (use-modules (guix build utils))
+
+ ;; Clean out /tmp and /var/run.
+ ;;
+ ;; XXX This needs to happen before service activations, so it
+ ;; has to be here, but this also implicitly assumes that /tmp
+ ;; and /var/run are on the root partition.
+ (letrec-syntax ((fail-safe (syntax-rules ()
+ ((_ exp rest ...)
+ (begin
+ (catch 'system-error
+ (lambda () exp)
+ (const #f))
+ (fail-safe rest ...)))
+ ((_)
+ #t))))
+ ;; Ignore I/O errors so the system can boot.
+ (fail-safe
+ ;; Remove stale Shadow lock files as they would lead to
+ ;; failures of 'useradd' & co.
+ (delete-file "/etc/group.lock")
+ (delete-file "/etc/passwd.lock")
+ (delete-file "/etc/.pwd.lock") ;from 'lckpwdf'
+
+ ;; Force file names to be decoded as UTF-8. See
+ ;; <https://bugs.gnu.org/26353>.
+ (setenv "GUIX_LOCPATH"
+ #+(file-append glibc-utf8-locales "/lib/locale"))
+ (setlocale LC_CTYPE "en_US.utf8")
+ (delete-file-recursively "/tmp")
+ (delete-file-recursively "/var/run")
+
+ (mkdir "/tmp")
+ (chmod "/tmp" #o1777)
+ (mkdir "/var/run")
+ (chmod "/var/run" #o755)
+ (delete-file-recursively "/run/udev/watch.old"))))))
(define cleanup-service-type
;; Service that cleans things up in /tmp and similar.
@@ -432,44 +429,39 @@ ACTIVATION-SCRIPT-TYPE."
(define (activation-script gexps)
"Return the system's activation script, which evaluates GEXPS."
- (define (service-activations)
- ;; Return the activation scripts for SERVICES.
- (mapm %store-monad
- (cut gexp->file "activate-service" <>)
- gexps))
-
- (mlet* %store-monad ((actions (service-activations)))
- (gexp->file "activate"
- (with-imported-modules (source-module-closure
- '((gnu build activation)
- (guix build utils)))
- #~(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 actions
+ (map (cut scheme-file "activate-service" <>) gexps))
+
+ (scheme-file "activate"
+ (with-imported-modules (source-module-closure
+ '((gnu build activation)
+ (guix build utils)))
+ #~(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."
- (mlet %store-monad ((script (activation-script gexps)))
- (return #~(primitive-load #$script))))
+ #~(primitive-load #$(activation-script gexps)))
(define (second-argument a b) b)
diff --git a/gnu/services/shepherd.scm b/gnu/services/shepherd.scm
index 000e85eb86..6ca53faa3d 100644
--- a/gnu/services/shepherd.scm
+++ b/gnu/services/shepherd.scm
@@ -22,7 +22,6 @@
#:use-module (guix sets)
#:use-module (guix gexp)
#:use-module (guix store)
- #:use-module (guix monads)
#:use-module (guix records)
#:use-module (guix derivations) ;imported-modules, etc.
#:use-module (gnu services)
@@ -66,26 +65,25 @@
(define (shepherd-boot-gexp services)
- (with-monad %store-monad
- (return #~(begin
- ;; Keep track of the booted system.
- (false-if-exception (delete-file "/run/booted-system"))
- (symlink (readlink "/run/current-system")
- "/run/booted-system")
-
- ;; Close any remaining open file descriptors to be on the safe
- ;; side. This must be the very last thing we do, because
- ;; Guile has internal FDs such as 'sleep_pipe' that need to be
- ;; alive.
- (let loop ((fd 3))
- (when (< fd 1024)
- (false-if-exception (close-fdes fd))
- (loop (+ 1 fd))))
-
- ;; Start shepherd.
- (execl #$(file-append shepherd "/bin/shepherd")
- "shepherd" "--config"
- #$(shepherd-configuration-file services))))))
+ #~(begin
+ ;; Keep track of the booted system.
+ (false-if-exception (delete-file "/run/booted-system"))
+ (symlink (readlink "/run/current-system")
+ "/run/booted-system")
+
+ ;; Close any remaining open file descriptors to be on the safe
+ ;; side. This must be the very last thing we do, because
+ ;; Guile has internal FDs such as 'sleep_pipe' that need to be
+ ;; alive.
+ (let loop ((fd 3))
+ (when (< fd 1024)
+ (false-if-exception (close-fdes fd))
+ (loop (+ 1 fd))))
+
+ ;; Start shepherd.
+ (execl #$(file-append shepherd "/bin/shepherd")
+ "shepherd" "--config"
+ #$(shepherd-configuration-file services))))
(define shepherd-root-service-type
(service-type
diff --git a/gnu/system.scm b/gnu/system.scm
index 7c51c4da97..84eab5f84f 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -819,7 +819,6 @@ we're running in the final root. When CONTAINER? is true, skip all
hardware-related operations as necessary when booting a Linux container."
(let* ((services (operating-system-services os #:container? container?))
(boot (fold-services services #:target-type boot-service-type)))
- ;; BOOT is the script as a monadic value.
(service-value boot)))
(define (operating-system-user-accounts os)
diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm
index d209066a74..4c24cf57f6 100644
--- a/gnu/tests/base.scm
+++ b/gnu/tests/base.scm
@@ -484,20 +484,19 @@ in a loop. See <http://bugs.gnu.org/26931>.")
(simple-operating-system
(simple-service 'dirty-things
boot-service-type
- (with-monad %store-monad
- (let ((script (plain-file
- "create-utf8-file.sh"
- (string-append
- "echo $0: dirtying /tmp...\n"
- "set -e; set -x\n"
- "touch /witness\n"
- "exec touch /tmp/λαμβδα"))))
- (with-imported-modules '((guix build utils))
- (return #~(begin
- (setenv "PATH"
- #$(file-append coreutils "/bin"))
- (invoke #$(file-append bash "/bin/sh")
- #$script)))))))))
+ (let ((script (plain-file
+ "create-utf8-file.sh"
+ (string-append
+ "echo $0: dirtying /tmp...\n"
+ "set -e; set -x\n"
+ "touch /witness\n"
+ "exec touch /tmp/λαμβδα"))))
+ (with-imported-modules '((guix build utils))
+ #~(begin
+ (setenv "PATH"
+ #$(file-append coreutils "/bin"))
+ (invoke #$(file-append bash "/bin/sh")
+ #$script)))))))
(define (run-cleanup-test name)
(define os
generated by cgit v1.2.3 (git 2.25.4) at 2024-11-05 13:41:39 +0000