nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

services: boot: Take gexps instead of monadic gexps. 

* gnu/services.scm (compute-boot-script): Rename 'mexps' to 'gexps' and
remove 'mlet' form.
(boot-service-type): Update comment.
(cleanup-gexp): Remove 'with-monad' and 'return'.
(activation-script): Rewrite in non-monadic style: use 'scheme-file'
instead of 'gexp->file'.
(gexps->activation-gexp): Remove 'mlet', return a gexp.
* gnu/services/shepherd.scm (shepherd-boot-gexp): Remove 'with-monad'
and 'return'.
* gnu/system.scm (operating-system-boot-script): Remove outdated comment.
* gnu/tests/base.scm (%cleanup-os): For 'dirty-service', remove
'with-monad' and 'return'.
This commit is contained in:
Ludovic Courtès 2018-06-20 11:01:07 +02:00
parent 636bb2b5e3
commit 378daa8cb6
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
4 changed files with 100 additions and 112 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

148
gnu/services.scm
View File

@ -337,15 +337,14 @@ containing the given entries."
turn refers to everything the operating system needs: its kernel, initrd, turn refers to everything the operating system needs: its kernel, initrd,
system profile, boot script, and so on."))) system profile, boot script, and so on.")))
(define (compute-boot-script _ mexps) (define (compute-boot-script _ gexps)
;; Reverse MEXPS so that extensions appear in the boot script in the right ;; Reverse GEXPS so that extensions appear in the boot script in the right
;; order. That is, user extensions would come first, and extensions added ;; order. That is, user extensions would come first, and extensions added
;; by 'essential-services' (e.g., running shepherd) are guaranteed to come ;; by 'essential-services' (e.g., running shepherd) are guaranteed to come
;; last. ;; last.
(mlet %store-monad ((gexps (sequence %store-monad (reverse mexps)))) (gexp->file "boot"
(gexp->file "boot" ;; Clean up and activate the system, then spawn shepherd.
;; Clean up and activate the system, then spawn shepherd. #~(begin #$@(reverse gexps))))
#~(begin #$@gexps))))
(define (boot-script-entry mboot) (define (boot-script-entry mboot)
"Return, as a monadic value, an entry for the boot script in the system "Return, as a monadic value, an entry for the boot script in the system
@ -354,9 +353,9 @@ directory."
(return `(("boot" ,boot))))) (return `(("boot" ,boot)))))
(define boot-service-type (define boot-service-type
;; The service of this type is extended by being passed gexps as monadic ;; The service of this type is extended by being passed gexps. It
;; values. It aggregates them in a single script, as a monadic value, which ;; aggregates them in a single script, as a monadic value, which becomes its
;; becomes its 'parameters'. It is the only service that extends nothing. ;; value.
(service-type (name 'boot) (service-type (name 'boot)
(extensions (extensions
(list (service-extension system-service-type (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)) (service boot-service-type #t))
(define (cleanup-gexp _) (define (cleanup-gexp _)
"Return as a monadic value a gexp to clean up /tmp and similar places upon "Return a gexp to clean up /tmp and similar places upon boot."
boot." (with-imported-modules '((guix build utils))
(with-monad %store-monad #~(begin
(with-imported-modules '((guix build utils)) (use-modules (guix build utils))
(return #~(begin
(use-modules (guix build utils))
;; Clean out /tmp and /var/run. ;; Clean out /tmp and /var/run.
;; ;;
;; XXX This needs to happen before service activations, so it ;; XXX This needs to happen before service activations, so it
;; has to be here, but this also implicitly assumes that /tmp ;; has to be here, but this also implicitly assumes that /tmp
;; and /var/run are on the root partition. ;; and /var/run are on the root partition.
(letrec-syntax ((fail-safe (syntax-rules () (letrec-syntax ((fail-safe (syntax-rules ()
((_ exp rest ...) ((_ exp rest ...)
(begin (begin
(catch 'system-error (catch 'system-error
(lambda () exp) (lambda () exp)
(const #f)) (const #f))
(fail-safe rest ...))) (fail-safe rest ...)))
((_) ((_)
#t)))) #t))))
;; Ignore I/O errors so the system can boot. ;; Ignore I/O errors so the system can boot.
(fail-safe (fail-safe
;; Remove stale Shadow lock files as they would lead to ;; Remove stale Shadow lock files as they would lead to
;; failures of 'useradd' & co. ;; failures of 'useradd' & co.
(delete-file "/etc/group.lock") (delete-file "/etc/group.lock")
(delete-file "/etc/passwd.lock") (delete-file "/etc/passwd.lock")
(delete-file "/etc/.pwd.lock") ;from 'lckpwdf' (delete-file "/etc/.pwd.lock") ;from 'lckpwdf'
;; Force file names to be decoded as UTF-8. See ;; Force file names to be decoded as UTF-8. See
;; <https://bugs.gnu.org/26353>. ;; <https://bugs.gnu.org/26353>.
(setenv "GUIX_LOCPATH" (setenv "GUIX_LOCPATH"
#+(file-append glibc-utf8-locales "/lib/locale")) #+(file-append glibc-utf8-locales "/lib/locale"))
(setlocale LC_CTYPE "en_US.utf8") (setlocale LC_CTYPE "en_US.utf8")
(delete-file-recursively "/tmp") (delete-file-recursively "/tmp")
(delete-file-recursively "/var/run") (delete-file-recursively "/var/run")
(mkdir "/tmp") (mkdir "/tmp")
(chmod "/tmp" #o1777) (chmod "/tmp" #o1777)
(mkdir "/var/run") (mkdir "/var/run")
(chmod "/var/run" #o755) (chmod "/var/run" #o755)
(delete-file-recursively "/run/udev/watch.old")))))))) (delete-file-recursively "/run/udev/watch.old"))))))
(define cleanup-service-type (define cleanup-service-type
;; Service that cleans things up in /tmp and similar. ;; Service that cleans things up in /tmp and similar.
@ -432,44 +429,39 @@ ACTIVATION-SCRIPT-TYPE."
(define (activation-script gexps) (define (activation-script gexps)
"Return the system's activation script, which evaluates GEXPS." "Return the system's activation script, which evaluates GEXPS."
(define (service-activations) (define actions
;; Return the activation scripts for SERVICES. (map (cut scheme-file "activate-service" <>) gexps))
(mapm %store-monad
(cut gexp->file "activate-service" <>)
gexps))
(mlet* %store-monad ((actions (service-activations))) (scheme-file "activate"
(gexp->file "activate" (with-imported-modules (source-module-closure
(with-imported-modules (source-module-closure '((gnu build activation)
'((gnu build activation) (guix build utils)))
(guix build utils))) #~(begin
#~(begin (use-modules (gnu build activation)
(use-modules (gnu build activation) (guix build utils))
(guix build utils))
;; Make sure the user accounting database exists. If it ;; Make sure the user accounting database exists. If it
;; does not exist, 'setutxent' does not create it and ;; does not exist, 'setutxent' does not create it and
;; thus there is no accounting at all. ;; thus there is no accounting at all.
(close-port (open-file "/var/run/utmpx" "a0")) (close-port (open-file "/var/run/utmpx" "a0"))
;; Same for 'wtmp', which is populated by mingetty et ;; Same for 'wtmp', which is populated by mingetty et
;; al. ;; al.
(mkdir-p "/var/log") (mkdir-p "/var/log")
(close-port (open-file "/var/log/wtmp" "a0")) (close-port (open-file "/var/log/wtmp" "a0"))
;; Set up /run/current-system. Among other things this ;; Set up /run/current-system. Among other things this
;; sets up locales, which the activation snippets ;; sets up locales, which the activation snippets
;; executed below may expect. ;; executed below may expect.
(activate-current-system) (activate-current-system)
;; Run the services' activation snippets. ;; Run the services' activation snippets.
;; TODO: Use 'load-compiled'. ;; TODO: Use 'load-compiled'.
(for-each primitive-load '#$actions)))))) (for-each primitive-load '#$actions)))))
(define (gexps->activation-gexp gexps) (define (gexps->activation-gexp gexps)
"Return a gexp that runs the activation script containing GEXPS." "Return a gexp that runs the activation script containing GEXPS."
(mlet %store-monad ((script (activation-script gexps))) #~(primitive-load #$(activation-script gexps)))
(return #~(primitive-load #$script))))
(define (second-argument a b) b) (define (second-argument a b) b)

36
gnu/services/shepherd.scm
View File

@ -22,7 +22,6 @@
#:use-module (guix sets) #:use-module (guix sets)
#:use-module (guix gexp) #:use-module (guix gexp)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix monads)
#:use-module (guix records) #:use-module (guix records)
#:use-module (guix derivations) ;imported-modules, etc. #:use-module (guix derivations) ;imported-modules, etc.
#:use-module (gnu services) #:use-module (gnu services)
@ -66,26 +65,25 @@
(define (shepherd-boot-gexp services) (define (shepherd-boot-gexp services)
(with-monad %store-monad #~(begin
(return #~(begin ;; Keep track of the booted system.
;; Keep track of the booted system. (false-if-exception (delete-file "/run/booted-system"))
(false-if-exception (delete-file "/run/booted-system")) (symlink (readlink "/run/current-system")
(symlink (readlink "/run/current-system") "/run/booted-system")
"/run/booted-system")
;; Close any remaining open file descriptors to be on the safe ;; Close any remaining open file descriptors to be on the safe
;; side. This must be the very last thing we do, because ;; side. This must be the very last thing we do, because
;; Guile has internal FDs such as 'sleep_pipe' that need to be ;; Guile has internal FDs such as 'sleep_pipe' that need to be
;; alive. ;; alive.
(let loop ((fd 3)) (let loop ((fd 3))
(when (< fd 1024) (when (< fd 1024)
(false-if-exception (close-fdes fd)) (false-if-exception (close-fdes fd))
(loop (+ 1 fd)))) (loop (+ 1 fd))))
;; Start shepherd. ;; Start shepherd.
(execl #$(file-append shepherd "/bin/shepherd") (execl #$(file-append shepherd "/bin/shepherd")
"shepherd" "--config" "shepherd" "--config"
#$(shepherd-configuration-file services)))))) #$(shepherd-configuration-file services))))
(define shepherd-root-service-type (define shepherd-root-service-type
(service-type (service-type

1
gnu/system.scm
View File

@ -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." hardware-related operations as necessary when booting a Linux container."
(let* ((services (operating-system-services os #:container? container?)) (let* ((services (operating-system-services os #:container? container?))
(boot (fold-services services #:target-type boot-service-type))) (boot (fold-services services #:target-type boot-service-type)))
;; BOOT is the script as a monadic value.
(service-value boot))) (service-value boot)))
(define (operating-system-user-accounts os) (define (operating-system-user-accounts os)

27
gnu/tests/base.scm
View File

@ -484,20 +484,19 @@ in a loop. See <http://bugs.gnu.org/26931>.")
(simple-operating-system (simple-operating-system
(simple-service 'dirty-things (simple-service 'dirty-things
boot-service-type boot-service-type
(with-monad %store-monad (let ((script (plain-file
(let ((script (plain-file "create-utf8-file.sh"
"create-utf8-file.sh" (string-append
(string-append "echo $0: dirtying /tmp...\n"
"echo $0: dirtying /tmp...\n" "set -e; set -x\n"
"set -e; set -x\n" "touch /witness\n"
"touch /witness\n" "exec touch /tmp/λαμβδα"))))
"exec touch /tmp/λαμβδα")))) (with-imported-modules '((guix build utils))
(with-imported-modules '((guix build utils)) #~(begin
(return #~(begin (setenv "PATH"
(setenv "PATH" #$(file-append coreutils "/bin"))
#$(file-append coreutils "/bin")) (invoke #$(file-append bash "/bin/sh")
(invoke #$(file-append bash "/bin/sh") #$script)))))))
#$script)))))))))
(define (run-cleanup-test name) (define (run-cleanup-test name)
(define os (define os