diff options
Diffstat (limited to 'gnu')
| -rw-r--r-- | gnu/services.scm | 164 | ||||
| -rw-r--r-- | gnu/services/shepherd.scm | 40 | ||||
| -rw-r--r-- | gnu/system.scm | 1 | ||||
| -rw-r--r-- | gnu/tests/base.scm | 27 |
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 |