;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
;;;
;;; This file is part of GNU Guix.
#:use-module (guix records)
#:use-module (guix profiles)
#:use-module (guix discovery)
+ #:use-module (guix combinators)
#:use-module (guix sets)
#:use-module (guix ui)
#:use-module ((guix utils) #:select (source-properties->location))
simple-service
modify-services
service-back-edges
+ instantiate-missing-services
fold-services
service-error?
(define (all-service-modules)
"Return the default set of service modules."
(cons (resolve-interface '(gnu services))
- (all-modules (%service-type-path))))
+ (all-modules (%service-type-path)
+ #:warn warn-about-load-error)))
(define* (fold-service-types proc seed
#:optional
(service-type (name 'system)
(extensions '())
(compose identity)
- (extend system-derivation)))
-
-(define (compute-boot-script _ mexps)
- (mlet %store-monad ((gexps (sequence %store-monad mexps)))
- (gexp->file "boot"
- ;; Clean up and activate the system, then spawn shepherd.
- #~(begin #$@gexps))))
+ (extend system-derivation)
+ (description
+ "Build the operating system top-level directory, which in
+turn refers to everything the operating system needs: its kernel, initrd,
+system profile, boot script, and so on.")))
+
+(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.
+ (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
(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
boot-script-entry)))
- (compose append)
- (extend compute-boot-script)))
+ (compose identity)
+ (extend compute-boot-script)
+ (description
+ "Produce the operating system's boot script, which is spawned
+by the initrd once the root file system is mounted.")))
(define %boot-service
;; The service that produces the boot script.
(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'
-
- (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.
(service-type (name 'cleanup)
(extensions
(list (service-extension boot-service-type
- cleanup-gexp)))))
+ cleanup-gexp)))
+ (description
+ "Delete files from @file{/tmp}, @file{/var/run}, and other
+temporary locations at boot time.")))
(define* (activation-service->script service)
"Return as a monadic value the activation script for SERVICE, a service of
(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)
(extensions
(list (service-extension boot-service-type
gexps->activation-gexp)))
- (compose append)
- (extend second-argument)))
+ (compose identity)
+ (extend second-argument)
+ (description
+ "Run @dfn{activation} code at boot time and upon
+@command{guix system reconfigure} completion.")))
(define %activation-service
;; The activation service produces the activation script from the gexps it
(lambda (files)
#~(activate-special-files '#$files)))))
(compose concatenate)
- (extend append)))
+ (extend append)
+ (description
+ "Add special files to the root file system---e.g.,
+@file{/usr/bin/env}.")))
(define (extra-special-file file target)
"Use TARGET as the \"special file\" FILE. For example, TARGET might be
#~(activate-etc #$etc))))
(service-extension system-service-type etc-entry)))
(compose concatenate)
- (extend append)))
+ (extend append)
+ (description "Populate the @file{/etc} directory.")))
(define (etc-service files)
"Return a new service of ETC-SERVICE-TYPE that populates /etc with FILES.
#~(activate-setuid-programs
(list #$@programs))))))
(compose concatenate)
- (extend append)))
+ (extend append)
+ (description
+ "Populate @file{/run/setuid-programs} with the specified
+executables, making them setuid-root.")))
(define (packages->profile-entry packages)
"Return a system entry for the profile containing PACKAGES."
(list (service-extension system-service-type
packages->profile-entry)))
(compose concatenate)
- (extend append)))
+ (extend append)
+ (description
+ "This is the @dfn{system profile}, available as
+@file{/run/current-system/profile}. It contains packages that the sysadmin
+wants to be globally available to all the system users.")))
(define (firmware->activation-gexp firmware)
"Return a gexp to make the packages listed in FIRMWARE loadable by the
(list (service-extension activation-service-type
firmware->activation-gexp)))
(compose concatenate)
- (extend append)))
+ (extend append)
+ (description
+ "Make ``firmware'' files loadable by the operating system
+kernel. Firmware may then be uploaded to some of the machine's devices, such
+as Wifi cards.")))
(define (gc-roots->system-entry roots)
"Return an entry in the system's output containing symlinks to ROOTS."
(list (service-extension system-service-type
gc-roots->system-entry)))
(compose concatenate)
- (extend append)))
+ (extend append)
+ (description
+ "Register garbage-collector roots---i.e., store items that
+will not be reclaimed by the garbage collector.")))
\f
;;;
(service ambiguous-target-service-error-service)
(target-type ambiguous-target-service-error-target-type))
+(define (missing-target-error service target-type)
+ (raise
+ (condition (&missing-target-service-error
+ (service service)
+ (target-type target-type))
+ (&message
+ (message
+ (format #f (G_ "no target of type '~a' for service '~a'")
+ (service-type-name target-type)
+ (service-type-name
+ (service-kind service))))))))
+
(define (service-back-edges services)
"Return a procedure that, when passed a <service>, returns the list of
<service> objects that depend on it."
((target)
(vhash-consq target service edges))
(()
- (raise
- (condition (&missing-target-service-error
- (service service)
- (target-type target-type))
- (&message
- (message
- (format #f (G_ "no target of type '~a' for service '~a'")
- (service-type-name target-type)
- (service-type-name
- (service-kind service))))))))
+ (missing-target-error service target-type))
(x
(raise
(condition (&ambiguous-target-service-error
(lambda (node)
(reverse (vhash-foldq* cons '() node edges)))))
+(define (instantiate-missing-services services)
+ "Return SERVICES, a list, augmented with any services targeted by extensions
+and missing from SERVICES. Only service types with a default value can be
+instantiated; other missing services lead to a
+'&missing-target-service-error'."
+ (define (adjust-service-list svc result instances)
+ (fold2 (lambda (extension result instances)
+ (define target-type
+ (service-extension-target extension))
+
+ (match (vhash-assq target-type instances)
+ (#f
+ (let ((default (service-type-default-value target-type)))
+ (if (eq? &no-default-value default)
+ (missing-target-error svc target-type)
+ (let ((new (service target-type)))
+ (values (cons new result)
+ (vhash-consq target-type new instances))))))
+ (_
+ (values result instances))))
+ result
+ instances
+ (service-type-extensions (service-kind svc))))
+
+ (let loop ((services services))
+ (define instances
+ (fold (lambda (service result)
+ (vhash-consq (service-kind service) service
+ result))
+ vlist-null services))
+
+ (define adjusted
+ (fold2 adjust-service-list
+ services instances
+ services))
+
+ ;; If we instantiated services, they might in turn depend on missing
+ ;; services. Loop until we've reached fixed point.
+ (if (= (length adjusted) (vlist-length instances))
+ adjusted
+ (loop adjusted))))
+
(define* (fold-services services
#:key (target-type system-service-type))
"Fold SERVICES by propagating their extensions down to the root of type