guix-bioinformatics
/
guix
mirror of http://git.savannah.gnu.org/git/guix.git
3
0
Fork 0
Code Issues Projects Releases Wiki Activity
Browse Source

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'.
version-0.15.0
Ludovic Courtès 4 years ago
parent
636bb2b5e3
commit
378daa8cb6
No known key found for this signature in database GPG Key ID: 90B11993D9AEBB5
4 changed files with 110 additions and 122 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 164
      gnu/services.scm
  2. 40
      gnu/services/shepherd.scm
  3. 1
      gnu/system.scm
  4. 27
      gnu/tests/base.scm

164
gnu/services.scm
View File

@ -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)

40
gnu/services/shepherd.scm
View File

@ -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

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."
(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)

27
gnu/tests/base.scm
View File

@ -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

Write Preview
Loading…
Cancel
Save