[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
13/13: PRELIM: services: Introduce extensible abstract services.
|
From: |
Ludovic Courtès |
|
Subject: |
13/13: PRELIM: services: Introduce extensible abstract services. |
|
Date: |
Mon, 21 Sep 2015 22:10:16 +0000 |
civodul pushed a commit to branch wip-service-refactor
in repository guix.
commit 130a64754a0a510e5eb845fad83d1897ab1324f7
Author: Ludovic Courtès <address@hidden>
Date: Thu Sep 17 23:44:26 2015 +0200
PRELIM: services: Introduce extensible abstract services.
Works well enough to run:
guix system vm gnu/system/examples/bare-bones.tmpl
and to boot the system.
---
gnu/services.scm | 349 +++++++++++++--
gnu/services/base.scm | 830 +++++++++++++++++++++--------------
gnu/services/dmd.scm | 72 +++-
gnu/system.scm | 361 +++-------------
gnu/system/examples/bare-bones.tmpl | 8 +-
gnu/system/linux.scm | 30 ++-
gnu/system/shadow.scm | 105 ++++-
7 files changed, 1068 insertions(+), 687 deletions(-)
diff --git a/gnu/services.scm b/gnu/services.scm
index 43e51b9..3638ea2 100644
--- a/gnu/services.scm
+++ b/gnu/services.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014 Ludovic Courtès <address@hidden>
+;;; Copyright © 2015 Ludovic Courtès <address@hidden>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -18,49 +18,318 @@
(define-module (gnu services)
#:use-module (guix gexp)
+ #:use-module (guix monads)
+ #:use-module (guix store)
#:use-module (guix records)
- #:export (service?
+ #:use-module (guix sets)
+ #:use-module (gnu packages base)
+ #:use-module (gnu packages bash)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
+ #:use-module (ice-9 vlist)
+ #:use-module (ice-9 match)
+ #:export (service-extension
+ service-extension?
+
+ service-type
+ service-type?
+
service
- service-documentation
- service-provision
- service-requirement
- service-respawn?
- service-start
- service-stop
- service-auto-start?
- service-activate
- service-user-accounts
- service-user-groups
- service-pam-services))
-
-;;; Commentary:
+ service?
+ service-kind
+ service-parameters
+
+ fold-services
+
+ boot-service-type
+ activation-service-type
+ etc-service-type
+ etc-directory
+
+ %boot-service
+ %activation-service
+ etc-service
+
+ file-union)) ;XXX: for lack of a better place
+
+
+(define-record-type <service-extension>
+ (service-extension target compute)
+ service-extension?
+ (target service-extension-target) ;<service-type>
+ (compute service-extension-compute)) ;params -> params
+
+(define-record-type* <service-type> service-type make-service-type
+ service-type?
+ (name service-type-name) ;symbol (for debugging)
+ (extensions service-type-extensions ;list of <service-extensions>
+ (default '()))
+ (extend service-type-extend ;list of Any -> arguments
+ (default #f)))
+
+(define (write-service-type type port)
+ (format port "#<service-type ~a ~a>"
+ (service-type-name type)
+ (number->string (object-address type) 16)))
+
+(set-record-type-printer! <service-type> write-service-type)
+
+(define-record-type* <service> service make-service
+ service?
+ (type service-kind)
+ (parameters service-parameters (default #f)))
+
+
+
+
;;;
-;;; System services as cajoled by dmd.
+;;; Core services.
;;;
-;;; Code:
-(define-record-type* <service>
- service make-service
- service?
- (documentation service-documentation ; string
- (default "[No documentation.]"))
- (provision service-provision) ; list of symbols
- (requirement service-requirement ; list of symbols
- (default '()))
- (respawn? service-respawn? ; Boolean
- (default #t))
- (start service-start) ; g-expression (procedure)
- (stop service-stop ; g-expression (procedure)
- (default #~(const #f)))
- (auto-start? service-auto-start? ; Boolean
- (default #t))
- (user-accounts service-user-accounts ; list of <user-account>
- (default '()))
- (user-groups service-user-groups ; list of <user-groups>
- (default '()))
- (pam-services service-pam-services ; list of <pam-service>
- (default '()))
- (activate service-activate ; gexp
- (default #f)))
+(define (compute-boot-script mexps)
+ (mlet %store-monad ((gexps (sequence %store-monad mexps)))
+ (gexp->file "boot"
+ #~(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.
+ (false-if-exception (delete-file-recursively "/tmp"))
+ (false-if-exception (delete-file-recursively "/var/run"))
+ (false-if-exception (mkdir "/tmp"))
+ (false-if-exception (chmod "/tmp" #o1777))
+ (false-if-exception (mkdir "/var/run"))
+ (false-if-exception (chmod "/var/run" #o755))
+
+ ;; Activate the system and spawn dmd.
+ address@hidden))))
+
+(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'.
+ (service-type (name 'boot)
+ (extend compute-boot-script)))
+
+(define %boot-service
+ ;; This is the ultimate service, the root of the service DAG.
+ (service (type boot-service-type)
+ (parameters (with-monad %store-monad (return #t)))))
+
+(define* (file-union name files) ;FIXME: Factorize.
+ "Return a <computed-file> that builds a directory containing all of FILES.
+Each item in FILES must be a list where the first element is the file name to
+use in the new directory, and the second element is a gexp denoting the target
+file."
+ (computed-file name
+ #~(begin
+ (mkdir #$output)
+ (chdir #$output)
+ #$@(map (match-lambda
+ ((target source)
+ #~(symlink #$source #$target)))
+ files))))
+
+(define (directory-union name things)
+ "Return a directory that is the union of THINGS."
+ (match things
+ ((one)
+ ;; Only one thing; return it.
+ one)
+ (_
+ (computed-file name
+ #~(begin
+ (use-modules (guix build union))
+ (union-build #$output '#$things))
+ #:modules '((guix build union))))))
+
+(define (modprobe-wrapper)
+ "Return a wrapper for the 'modprobe' command that knows where modules live.
+
+This wrapper is typically invoked by the Linux kernel ('call_modprobe', in
+kernel/kmod.c), a situation where the 'LINUX_MODULE_DIRECTORY' environment
+variable is not set---hence the need for this wrapper."
+ (let ((modprobe "/run/current-system/profile/bin/modprobe"))
+ (gexp->script "modprobe"
+ #~(begin
+ (setenv "LINUX_MODULE_DIRECTORY"
+ "/run/booted-system/kernel/lib/modules")
+ (apply execl #$modprobe
+ (cons #$modprobe (cdr (command-line))))))))
+
+(define* (activation-script gexps
+ ;; FIXME: Should be in <activation-parameters>.
+ #:key container?
+ (firmware '()))
+ "Return as a monadic value a file that runs GEXPS."
+ (define %modules
+ '((gnu build activation)
+ (gnu build linux-boot)
+ (gnu build linux-modules)
+ (gnu build file-systems)
+ (guix build utils)
+ (guix build syscalls)
+ (guix elf)))
+
+ (define (service-activations)
+ ;; Return the activation scripts for SERVICES.
+ (mapm %store-monad
+ (cut gexp->file "activate-service" <>)
+ gexps))
+
+ (mlet* %store-monad ((actions (service-activations))
+ (modules (imported-modules %modules))
+ (compiled (compiled-modules %modules))
+ (modprobe (modprobe-wrapper))
+ (firmware -> (directory-union
+ "firmware" firmware)))
+ (define setuid-progs
+ '()) ;FIXME
+
+ (gexp->file "activate"
+ #~(begin
+ (eval-when (expand load eval)
+ ;; Make sure 'use-modules' below succeeds.
+ (set! %load-path (cons #$modules %load-path))
+ (set! %load-compiled-path
+ (cons #$compiled %load-compiled-path)))
+
+ (use-modules (gnu build activation))
+
+ ;; Make sure /bin/sh is valid and current.
+ (activate-/bin/sh
+ (string-append #$(canonical-package bash) "/bin/sh"))
+
+ ;; Activate setuid programs.
+ (activate-setuid-programs (list address@hidden))
+
+ ;; Tell the kernel to use our 'modprobe' command.
+ (activate-modprobe #$modprobe)
+
+ ;; Tell the kernel where firmware is, unless we are
+ ;; activating a container.
+ #$@(if container?
+ #~()
+ ;; Tell the kernel where firmware is.
+ #~((activate-firmware
+ (string-append #$firmware "/lib/firmware"))
+ ;; Let users debug their own processes!
+ (activate-ptrace-attach)))
+
+ ;; Run the services' activation snippets.
+ ;; TODO: Use 'load-compiled'.
+ (for-each primitive-load '#$actions)
+
+ ;; Set up /run/current-system.
+ (activate-current-system)))))
+
+(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))))
+
+(define activation-service-type
+ (service-type (name 'activate)
+ (extensions
+ (list (service-extension boot-service-type
+ gexps->activation-gexp)))
+ (extend append)))
+
+(define %activation-service
+ (service (type activation-service-type)
+ (parameters #t))) ;list of gexps
+
+(define (etc-directory service)
+ "Return the directory for SERVICE, a service of type ETC-SERVICE-TYPE."
+ (files->etc-directory (service-parameters service)))
+
+(define (files->etc-directory files)
+ (file-union "etc" files))
+
+(define etc-service-type
+ (service-type (name 'etc)
+ (extensions
+ (list
+ (service-extension activation-service-type
+ (lambda (files)
+ (let ((etc
+ (files->etc-directory files)))
+ #~(activate-etc #$etc))))))
+ (extend concatenate)))
+
+(define (etc-service files)
+ "Return a new service of ETC-SERVICE-TYPE that populates /etc with FILES.
+FILES must be a list of name/file-like object pairs."
+ (service (type etc-service-type)
+ (parameters files))) ;list of name/file pairs
+
+
+;;;
+;;; Service folding.
+;;;
+
+(define (service-back-edges services)
+ "Return a procedure that, when passed a <service>, returns the list of
+<service> objects that depend on it."
+ (define (add-edges service edges)
+ (define (add-edge extension edges)
+ (let ((target-type (service-extension-target extension)))
+ (match (filter (lambda (service)
+ (eq? (service-kind service) target-type))
+ services)
+ ((target)
+ (vhash-consq target service edges))
+ (()
+ (error "no target service" service target-type))
+ (x
+ (error "more than one target service" x)))))
+
+ (fold add-edge edges (service-type-extensions (service-kind service))))
+
+ (let ((edges (fold add-edges vlist-null services)))
+ (lambda (node)
+ (reverse (vhash-foldq* cons '() node edges)))))
+
+(define* (fold-services services #:key (target-type boot-service-type))
+ "Fold SERVICES by propagating their extensions down to the root of type
+BOOT-SERVICE-TYPE; return the root service adjusted accordingly."
+ (define dependents
+ (service-back-edges services))
+
+ (define (matching-extension target)
+ (let ((target (service-kind target)))
+ (match-lambda
+ (($ <service-extension> type)
+ (eq? type target)))))
+
+ (define (apply-extension target)
+ (lambda (service)
+ (match (find (matching-extension target)
+ (service-type-extensions (service-kind service)))
+ (($ <service-extension> _ compute)
+ (compute (service-parameters service))))))
+
+ (match (filter (lambda (service)
+ (eq? (service-kind service) target-type))
+ services)
+ ((sink)
+ (let loop ((sink sink))
+ (let* ((dependents (map loop (dependents sink)))
+ (extensions (map (apply-extension sink) dependents))
+ (extend (service-type-extend (service-kind sink)))
+ (params (service-parameters sink)))
+ (if extend
+ (service (inherit sink)
+ (parameters (extend (cons params extensions))))
+ sink))))
+ (()
+ (error "no target service" target-type))
+ (x
+ (error "more than one target service" x))))
;;; services.scm ends here.
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 7b68111..274ff83 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -21,9 +21,11 @@
(define-module (gnu services base)
#:use-module (guix store)
#:use-module (gnu services)
- #:use-module (gnu services networking)
+ #:use-module (gnu services dmd)
+ ;; #:use-module (gnu services networking)
#:use-module (gnu system shadow) ; 'user-account', etc.
#:use-module (gnu system linux) ; 'pam-service', etc.
+ #:use-module (gnu system file-systems) ; 'file-system', etc.
#:use-module (gnu packages admin)
#:use-module ((gnu packages linux)
#:select (eudev kbd e2fsprogs lvm2 fuse alsa-utils crda))
@@ -76,13 +78,8 @@
;;;
;;; Code:
-(define (root-file-system-service)
- "Return a service whose sole purpose is to re-mount read-only the root file
-system upon shutdown (aka. cleanly \"umounting\" root.)
-
-This service must be the root of the service dependency graph so that its
-'stop' action is invoked when dmd is the only process left."
- (service
+(define %root-file-system-dmd-service
+ (dmd-service
(documentation "Take care of the root file system.")
(provision '(root-file-system))
(start #~(const #t))
@@ -116,10 +113,81 @@ This service must be the root of the service dependency
graph so that its
#f)))))
(respawn? #f)))
-(define* (file-system-service device target type
- #:key (flags '()) (check? #t)
- create-mount-point? options (title 'any)
- (requirements '()))
+(define root-file-system-service-type
+ (dmd-service-type (const %root-file-system-dmd-service)))
+
+(define (root-file-system-service)
+ "Return a service whose sole purpose is to re-mount read-only the root file
+system upon shutdown (aka. cleanly \"umounting\" root.)
+
+This service must be the root of the service dependency graph so that its
+'stop' action is invoked when dmd is the only process left."
+ (service (type root-file-system-service-type)))
+
+(define (file-system->dmd-service-name file-system)
+ "Return the symbol that denotes the service mounting and unmounting
+FILE-SYSTEM."
+ (symbol-append 'file-system-
+ (string->symbol (file-system-mount-point file-system))))
+
+(define file-system-service-type
+ ;; TODO(?): Alternately this could be an extensible service that returns a
+ ;; list of <dmd-service>.
+ (dmd-service-type
+ (lambda (file-system)
+ (let ((target (file-system-mount-point file-system))
+ (device (file-system-device file-system))
+ (type (file-system-type file-system))
+ (title (file-system-title file-system))
+ (check? (file-system-check? file-system))
+ (create? (file-system-create-mount-point? file-system))
+ (dependencies (file-system-dependencies file-system)))
+ (dmd-service
+ (provision (list (file-system->dmd-service-name file-system)))
+ (requirement `(root-file-system
+ ,@(map file-system->dmd-service-name dependencies)))
+ (documentation "Check, mount, and unmount the given file system.")
+ (start #~(lambda args
+ ;; FIXME: Use or factorize with 'mount-file-system'.
+ (let ((device (canonicalize-device-spec #$device '#$title))
+ (flags #$(mount-flags->bit-mask
+ (file-system-flags file-system))))
+ #$(if create?
+ #~(mkdir-p #$target)
+ #~#t)
+ #$(if check?
+ #~(begin
+ ;; Make sure fsck.ext2 & co. can be found.
+ (setenv "PATH"
+ (string-append
+ #$e2fsprogs "/sbin:"
+ "/run/current-system/profile/sbin:"
+ (getenv "PATH")))
+ (check-file-system device #$type))
+ #~#t)
+
+ (mount device #$target #$type flags
+ #$(file-system-options file-system))
+
+ ;; For read-only bind mounts, an extra remount is needed,
+ ;; as per <http://lwn.net/Articles/281157/>, which still
+ ;; applies to Linux 4.0.
+ (when (and (= MS_BIND (logand flags MS_BIND))
+ (= MS_RDONLY (logand flags MS_RDONLY)))
+ (mount device #$target #$type
+ (logior MS_BIND MS_REMOUNT MS_RDONLY))))
+ #t))
+ (stop #~(lambda args
+ ;; Normally there are no processes left at this point, so
+ ;; TARGET can be safely unmounted.
+
+ ;; Make sure PID 1 doesn't keep TARGET busy.
+ (chdir "/")
+
+ (umount #$target)
+ #f)))))))
+
+(define* (file-system-service file-system)
"Return a service that mounts DEVICE on TARGET as a file system TYPE with
OPTIONS. TITLE is a symbol specifying what kind of name DEVICE is: 'label for
a partition label, 'device for a device file name, or 'any. When CHECK? is
@@ -127,170 +195,151 @@ true, check the file system before mounting it. When
CREATE-MOUNT-POINT? is
true, create TARGET if it does not exist yet. FLAGS is a list of symbols,
such as 'read-only' etc. Optionally, REQUIREMENTS may be a list of service
names such as device-mapping services."
- (service
- (provision (list (symbol-append 'file-system- (string->symbol target))))
- (requirement `(root-file-system ,@requirements))
- (documentation "Check, mount, and unmount the given file system.")
- (start #~(lambda args
- ;; FIXME: Use or factorize with 'mount-file-system'.
- (let ((device (canonicalize-device-spec #$device '#$title))
- (flags #$(mount-flags->bit-mask flags)))
- #$(if create-mount-point?
- #~(mkdir-p #$target)
- #~#t)
- #$(if check?
- #~(begin
- ;; Make sure fsck.ext2 & co. can be found.
- (setenv "PATH"
- (string-append
- #$e2fsprogs "/sbin:"
- "/run/current-system/profile/sbin:"
- (getenv "PATH")))
- (check-file-system device #$type))
- #~#t)
-
- (mount device #$target #$type flags #$options)
-
- ;; For read-only bind mounts, an extra remount is needed,
- ;; as per <http://lwn.net/Articles/281157/>, which still
- ;; applies to Linux 4.0.
- (when (and (= MS_BIND (logand flags MS_BIND))
- (= MS_RDONLY (logand flags MS_RDONLY)))
- (mount device #$target #$type
- (logior MS_BIND MS_REMOUNT MS_RDONLY))))
- #t))
- (stop #~(lambda args
- ;; Normally there are no processes left at this point, so
- ;; TARGET can be safely unmounted.
-
- ;; Make sure PID 1 doesn't keep TARGET busy.
- (chdir "/")
-
- (umount #$target)
- #f))))
+ (service (type file-system-service-type)
+ (parameters file-system)))
+
+(define user-unmount-service-type
+ (dmd-service-type
+ (lambda (known-mount-points)
+ (dmd-service
+ (documentation "Unmount manually-mounted file systems.")
+ (provision '(user-unmount))
+ (start #~(const #t))
+ (stop #~(lambda args
+ (define (known? mount-point)
+ (member mount-point
+ (cons* "/proc" "/sys" '#$known-mount-points)))
+
+ ;; Make sure we don't keep the user's mount points busy.
+ (chdir "/")
+
+ (for-each (lambda (mount-point)
+ (format #t "unmounting '~a'...~%" mount-point)
+ (catch 'system-error
+ (lambda ()
+ (umount mount-point))
+ (lambda args
+ (let ((errno (system-error-errno args)))
+ (format #t "failed to unmount '~a': ~a~%"
+ mount-point (strerror errno))))))
+ (filter (negate known?) (mount-points)))
+ #f))))))
(define (user-unmount-service known-mount-points)
"Return a service whose sole purpose is to unmount file systems not listed
in KNOWN-MOUNT-POINTS when it is stopped."
- (service
- (documentation "Unmount manually-mounted file systems.")
- (provision '(user-unmount))
- (start #~(const #t))
- (stop #~(lambda args
- (define (known? mount-point)
- (member mount-point
- (cons* "/proc" "/sys"
- '#$known-mount-points)))
-
- ;; Make sure we don't keep the user's mount points busy.
- (chdir "/")
-
- (for-each (lambda (mount-point)
- (format #t "unmounting '~a'...~%" mount-point)
- (catch 'system-error
- (lambda ()
- (umount mount-point))
- (lambda args
- (let ((errno (system-error-errno args)))
- (format #t "failed to unmount '~a': ~a~%"
- mount-point (strerror errno))))))
- (filter (negate known?) (mount-points)))
- #f))))
+ (service (type user-unmount-service-type)
+ (parameters known-mount-points)))
(define %do-not-kill-file
;; Name of the file listing PIDs of processes that must survive when halting
;; the system. Typical example is user-space file systems.
"/etc/dmd/do-not-kill")
-(define* (user-processes-service requirements #:key (grace-delay 4))
+(define user-processes-service-type
+ (dmd-service-type
+ (match-lambda
+ ((requirements grace-delay)
+ (dmd-service
+ (documentation "When stopped, terminate all user processes.")
+ (provision '(user-processes))
+ (requirement (cons 'root-file-system
+ (map file-system->dmd-service-name
+ requirements)))
+ (start #~(const #t))
+ (stop #~(lambda _
+ (define (kill-except omit signal)
+ ;; Kill all the processes with SIGNAL except those listed
+ ;; in OMIT and the current process.
+ (let ((omit (cons (getpid) omit)))
+ (for-each (lambda (pid)
+ (unless (memv pid omit)
+ (false-if-exception
+ (kill pid signal))))
+ (processes))))
+
+ (define omitted-pids
+ ;; List of PIDs that must not be killed.
+ (if (file-exists? #$%do-not-kill-file)
+ (map string->number
+ (call-with-input-file #$%do-not-kill-file
+ (compose string-tokenize
+ (@ (ice-9 rdelim) read-string))))
+ '()))
+
+ (define (now)
+ (car (gettimeofday)))
+
+ (define (sleep* n)
+ ;; Really sleep N seconds.
+ ;; Work around <http://bugs.gnu.org/19581>.
+ (define start (now))
+ (let loop ((elapsed 0))
+ (when (> n elapsed)
+ (sleep (- n elapsed))
+ (loop (- (now) start)))))
+
+ (define lset= (@ (srfi srfi-1) lset=))
+
+ (display "sending all processes the TERM signal\n")
+
+ (if (null? omitted-pids)
+ (begin
+ ;; Easy: terminate all of them.
+ (kill -1 SIGTERM)
+ (sleep* #$grace-delay)
+ (kill -1 SIGKILL))
+ (begin
+ ;; Kill them all except OMITTED-PIDS. XXX: We would
+ ;; like to (kill -1 SIGSTOP) to get a fixed list of
+ ;; processes, like 'killall5' does, but that seems
+ ;; unreliable.
+ (kill-except omitted-pids SIGTERM)
+ (sleep* #$grace-delay)
+ (kill-except omitted-pids SIGKILL)
+ (delete-file #$%do-not-kill-file)))
+
+ (let wait ()
+ (let ((pids (processes)))
+ (unless (lset= = pids (cons 1 omitted-pids))
+ (format #t "waiting for process termination\
+ (processes left: ~s)~%"
+ pids)
+ (sleep* 2)
+ (wait))))
+
+ (display "all processes have been terminated\n")
+ #f))
+ (respawn? #f))))))
+
+(define* (user-processes-service file-systems #:key (grace-delay 4))
"Return the service that is responsible for terminating all the processes so
that the root file system can be re-mounted read-only, just before
rebooting/halting. Processes still running GRACE-DELAY seconds after SIGTERM
has been sent are terminated with SIGKILL.
-The returned service will depend on 'root-file-system' and on all the services
-listed in REQUIREMENTS.
+The returned service will depend on 'root-file-system' and on all the dmd
+services corresponding to FILE-SYSTEMS.
All the services that spawn processes must depend on this one so that they are
stopped before 'kill' is called."
- (service
- (documentation "When stopped, terminate all user processes.")
- (provision '(user-processes))
- (requirement (cons 'root-file-system requirements))
- (start #~(const #t))
- (stop #~(lambda _
- (define (kill-except omit signal)
- ;; Kill all the processes with SIGNAL except those
- ;; listed in OMIT and the current process.
- (let ((omit (cons (getpid) omit)))
- (for-each (lambda (pid)
- (unless (memv pid omit)
- (false-if-exception
- (kill pid signal))))
- (processes))))
-
- (define omitted-pids
- ;; List of PIDs that must not be killed.
- (if (file-exists? #$%do-not-kill-file)
- (map string->number
- (call-with-input-file #$%do-not-kill-file
- (compose string-tokenize
- (@ (ice-9 rdelim) read-string))))
- '()))
-
- (define (now)
- (car (gettimeofday)))
-
- (define (sleep* n)
- ;; Really sleep N seconds.
- ;; Work around <http://bugs.gnu.org/19581>.
- (define start (now))
- (let loop ((elapsed 0))
- (when (> n elapsed)
- (sleep (- n elapsed))
- (loop (- (now) start)))))
-
- (define lset= (@ (srfi srfi-1) lset=))
-
- (display "sending all processes the TERM signal\n")
-
- (if (null? omitted-pids)
- (begin
- ;; Easy: terminate all of them.
- (kill -1 SIGTERM)
- (sleep* #$grace-delay)
- (kill -1 SIGKILL))
- (begin
- ;; Kill them all except OMITTED-PIDS. XXX: We
- ;; would like to (kill -1 SIGSTOP) to get a fixed
- ;; list of processes, like 'killall5' does, but
- ;; that seems unreliable.
- (kill-except omitted-pids SIGTERM)
- (sleep* #$grace-delay)
- (kill-except omitted-pids SIGKILL)
- (delete-file #$%do-not-kill-file)))
-
- (let wait ()
- (let ((pids (processes)))
- (unless (lset= = pids (cons 1 omitted-pids))
- (format #t "waiting for process termination\
- (processes left: ~s)~%"
- pids)
- (sleep* 2)
- (wait))))
-
- (display "all processes have been terminated\n")
- #f))
- (respawn? #f)))
+ (service (type user-processes-service-type)
+ (parameters (list file-systems grace-delay))))
+
+(define host-name-service-type
+ (dmd-service-type
+ (lambda (name)
+ (dmd-service
+ (documentation "Initialize the machine's host name.")
+ (provision '(host-name))
+ (start #~(lambda _
+ (sethostname #$name)))
+ (respawn? #f)))))
(define (host-name-service name)
"Return a service that sets the host name to @var{name}."
- (service
- (documentation "Initialize the machine's host name.")
- (provision '(host-name))
- (start #~(lambda _
- (sethostname #$name)))
- (respawn? #f)))
+ (service (type host-name-service-type)
+ (parameters name)))
(define (unicode-start tty)
"Return a gexp to start Unicode support on @var{tty}."
@@ -310,15 +359,44 @@ stopped before 'kill' is called."
(else
(zero? (cdr (waitpid pid))))))))
+(define console-keymap-service-type
+ (dmd-service-type
+ (lambda (file)
+ (dmd-service
+ (documentation (string-append "Load console keymap (loadkeys)."))
+ (provision '(console-keymap))
+ (start #~(lambda _
+ (zero? (system* (string-append #$kbd "/bin/loadkeys")
+ #$file))))
+ (respawn? #f)))))
+
(define (console-keymap-service file)
"Return a service to load console keymap from @var{file}."
- (service
- (documentation (string-append "Load console keymap (loadkeys)."))
- (provision '(console-keymap))
- (start #~(lambda _
- (zero? (system* (string-append #$kbd "/bin/loadkeys")
- #$file))))
- (respawn? #f)))
+ (service (type console-keymap-service-type)
+ (parameters file)))
+
+(define console-font-service-type
+ (dmd-service-type
+ (match-lambda
+ ((tty font)
+ (let ((device (string-append "/dev/" tty)))
+ (dmd-service
+ (documentation "Load a Unicode console font.")
+ (provision (list (symbol-append 'console-font-
+ (string->symbol tty))))
+
+ ;; Start after mingetty has been started on TTY, otherwise the
settings
+ ;; are ignored.
+ (requirement (list (symbol-append 'term-
+ (string->symbol tty))))
+
+ (start #~(lambda _
+ (and #$(unicode-start device)
+ (zero?
+ (system* (string-append #$kbd "/bin/setfont")
+ "-C" #$device #$font)))))
+ (stop #~(const #t))
+ (respawn? #f)))))))
(define* (console-font-service tty #:optional (font "LatGrkCyr-8x16"))
"Return a service that sets up Unicode support in @var{tty} and loads
@@ -326,24 +404,8 @@ stopped before 'kill' is called."
;; Note: 'LatGrkCyr-8x16' has the advantage of providing three common
;; scripts as well as glyphs for em dash, quotation marks, and other Unicode
;; codepoints notably found in the UTF-8 manual.
- (let ((device (string-append "/dev/" tty)))
- (service
- (documentation "Load a Unicode console font.")
- (provision (list (symbol-append 'console-font-
- (string->symbol tty))))
-
- ;; Start after mingetty has been started on TTY, otherwise the
- ;; settings are ignored.
- (requirement (list (symbol-append 'term-
- (string->symbol tty))))
-
- (start #~(lambda _
- (and #$(unicode-start device)
- (zero?
- (system* (string-append #$kbd "/bin/setfont")
- "-C" #$device #$font)))))
- (stop #~(const #t))
- (respawn? #f))))
+ (service (type console-font-service-type)
+ (parameters (list tty font))))
(define-record-type* <mingetty-configuration>
mingetty-configuration make-mingetty-configuration
@@ -363,42 +425,57 @@ stopped before 'kill' is called."
(allow-empty-passwords? mingetty-configuration-allow-empty-passwords?
(default #t))) ;Boolean
+(define (mingetty-pam-service conf)
+ "Return the list of PAM service needed for CONF."
+ ;; Let 'login' be known to PAM. All the mingetty services will have that
+ ;; PAM service, but that's fine because they're all identical and duplicates
+ ;; are removed.
+ (list (unix-pam-service "login"
+ #:allow-empty-passwords?
+ (mingetty-configuration-allow-empty-passwords? conf)
+ #:motd
+ (mingetty-configuration-motd conf))))
+
+(define mingetty-dmd-service
+ (match-lambda
+ (($ <mingetty-configuration> tty motd auto-login login-program
+ login-pause? allow-empty-passwords?)
+ (list
+ (dmd-service
+ (documentation "Run mingetty on an tty.")
+ (provision (list (symbol-append 'term- (string->symbol tty))))
+
+ ;; Since the login prompt shows the host name, wait for the 'host-name'
+ ;; service to be done. Also wait for udev essentially so that the tty
+ ;; text is not lost in the middle of kernel messages (XXX).
+ (requirement '(user-processes host-name udev))
+
+ (start #~(make-forkexec-constructor
+ (list (string-append #$mingetty "/sbin/mingetty")
+ "--noclear" #$tty
+ #$@(if auto-login
+ #~("--autologin" #$auto-login)
+ #~())
+ #$@(if login-program
+ #~("--loginprog" #$login-program)
+ #~())
+ #$@(if login-pause?
+ #~("--loginpause")
+ #~()))))
+ (stop #~(make-kill-destructor)))))))
+
+(define mingetty-service-type
+ (service-type (name 'mingetty)
+ (extensions (list (service-extension dmd-root-service-type
+ mingetty-dmd-service)
+ (service-extension pam-root-service-type
+ mingetty-pam-service)))))
+
(define* (mingetty-service config)
"Return a service to run mingetty according to @var{config}, which specifies
the tty to run, among other things."
- (match config
- (($ <mingetty-configuration> tty motd auto-login login-program
- login-pause? allow-empty-passwords?)
- (service
- (documentation "Run mingetty on an tty.")
- (provision (list (symbol-append 'term- (string->symbol tty))))
-
- ;; Since the login prompt shows the host name, wait for the 'host-name'
- ;; service to be done. Also wait for udev essentially so that the tty
- ;; text is not lost in the middle of kernel messages (XXX).
- (requirement '(user-processes host-name udev))
-
- (start #~(make-forkexec-constructor
- (list (string-append #$mingetty "/sbin/mingetty")
- "--noclear" #$tty
- #$@(if auto-login
- #~("--autologin" #$auto-login)
- #~())
- #$@(if login-program
- #~("--loginprog" #$login-program)
- #~())
- #$@(if login-pause?
- #~("--loginpause")
- #~()))))
- (stop #~(make-kill-destructor))
-
- (pam-services
- ;; Let 'login' be known to PAM. All the mingetty services will have
- ;; that PAM service, but that's fine because they're all identical and
- ;; duplicates are removed.
- (list (unix-pam-service "login"
- #:allow-empty-passwords? allow-empty-passwords?
- #:motd motd)))))))
+ (service (type mingetty-service-type)
+ (parameters config)))
(define-record-type* <nscd-configuration> nscd-configuration
make-nscd-configuration
@@ -503,38 +580,63 @@ the tty to run, among other things."
(string-concatenate
(map cache->config caches)))))))
+(define (nscd-dmd-service config)
+ "Return a dmd service for CONFIG, an <nscd-configuration> object."
+ (let ((nscd.conf (nscd.conf-file config))
+ (name-services (nscd-configuration-name-services config)))
+ (list (dmd-service
+ (documentation "Run libc's name service cache daemon (nscd).")
+ (provision '(nscd))
+ (requirement '(user-processes))
+ (start #~(make-forkexec-constructor
+ (list (string-append #$(nscd-configuration-glibc config)
+ "/sbin/nscd")
+ "-f" #$nscd.conf "--foreground")
+
+ #:environment-variables
+ (list (string-append "LD_LIBRARY_PATH="
+ (string-join
+ (map (lambda (dir)
+ (string-append dir "/lib"))
+ (list address@hidden))
+ ":")))))
+ (stop #~(make-kill-destructor))
+
+ (respawn? #f)))))
+
+(define nscd-activation
+ ;; Actions to take before starting nscd.
+ #~(begin
+ (use-modules (guix build utils))
+ (mkdir-p "/var/run/nscd")
+ (mkdir-p "/var/db/nscd"))) ;for the persistent cache
+
+(define nscd-service-type
+ (service-type (name 'nscd)
+ (extensions
+ (list (service-extension activation-service-type
+ (const nscd-activation))
+ (service-extension dmd-root-service-type
+ nscd-dmd-service)))))
+
(define* (nscd-service #:optional (config %nscd-default-configuration))
"Return a service that runs libc's name service cache daemon (nscd) with the
given @var{config}---an @code{<nscd-configuration>} object. @xref{Name
Service Switch}, for an example."
- (let ((nscd.conf (nscd.conf-file config)))
- (service
- (documentation "Run libc's name service cache daemon (nscd).")
- (provision '(nscd))
- (requirement '(user-processes))
-
- (activate #~(begin
- (use-modules (guix build utils))
- (mkdir-p "/var/run/nscd")
- (mkdir-p "/var/db/nscd"))) ;for the persistent cache
-
- (start #~(make-forkexec-constructor
- (list (string-append #$(nscd-configuration-glibc config)
- "/sbin/nscd")
- "-f" #$nscd.conf "--foreground")
-
- #:environment-variables
- (list (string-append "LD_LIBRARY_PATH="
- (string-join
- (map (lambda (dir)
- (string-append dir "/lib"))
- (list
- #$@(nscd-configuration-name-services
- config)))
- ":")))))
- (stop #~(make-kill-destructor))
-
- (respawn? #f))))
+ (service (type nscd-service-type)
+ (parameters config)))
+
+(define syslog-service-type
+ (dmd-service-type
+ (lambda (config-file)
+ (dmd-service
+ (documentation "Run the syslog daemon (syslogd).")
+ (provision '(syslogd))
+ (requirement '(user-processes))
+ (start #~(make-forkexec-constructor
+ (list (string-append #$inetutils "/libexec/syslogd")
+ "--no-detach" "--rcfile" #$config-file)))
+ (stop #~(make-kill-destructor))))))
;; Snippet adapted from the GNU inetutils manual.
(define %default-syslog.conf
@@ -558,18 +660,13 @@ Service Switch}, for an example."
# Log all the mail messages in one place.
mail.* /var/log/maillog
"))
+
(define* (syslog-service #:key (config-file %default-syslog.conf))
"Return a service that runs @code{syslogd}.
If configuration file name @var{config-file} is not specified, use some
reasonable default settings."
- (service
- (documentation "Run the syslog daemon (syslogd).")
- (provision '(syslogd))
- (requirement '(user-processes))
- (start #~(make-forkexec-constructor
- (list (string-append #$inetutils "/libexec/syslogd")
- "--no-detach" "--rcfile" #$config-file)))
- (stop #~(make-kill-destructor))))
+ (service (type syslog-service-type)
+ (parameters config-file)))
(define* (guix-build-accounts count #:key
(group "guixbuild")
@@ -618,61 +715,95 @@ GUIX."
(format (current-error-port) "warning: \
failed to register hydra.gnu.org public key: ~a~%" status))))))))
-(define* (guix-service #:key (guix guix) (builder-group "guixbuild")
- (build-accounts 10) (authorize-hydra-key? #t)
- (use-substitutes? #t)
- (extra-options '())
- (lsof lsof) (lsh lsh))
- "Return a service that runs the build daemon from @var{guix}, and has
address@hidden user accounts available under @var{builder-group}.
-
-When @var{authorize-hydra-key?} is true, the @code{hydra.gnu.org} public key
-provided by @var{guix} is authorized upon activation, meaning that substitutes
-from @code{hydra.gnu.org} are used by default.
-
-If @var{use-substitutes?} is false, the daemon is run with
address@hidden (@pxref{Invoking guix-daemon,
address@hidden).
-
-Finally, @var{extra-options} is a list of additional command-line options
-passed to @command{guix-daemon}."
- (define activate
- ;; Assume that the store has BUILDER-GROUP as its group. We could
- ;; otherwise call 'chown' here, but the problem is that on a COW unionfs,
- ;; chown leads to an entire copy of the tree, which is a bad idea.
-
- ;; Optionally authorize hydra.gnu.org's key.
- (and authorize-hydra-key?
- (hydra-key-authorization guix)))
-
- (service
- (documentation "Run the Guix daemon.")
- (provision '(guix-daemon))
- (requirement '(user-processes))
- (start
- #~(make-forkexec-constructor
- (list (string-append #$guix "/bin/guix-daemon")
- "--build-users-group" #$builder-group
- #$@(if use-substitutes?
- '()
- '("--no-substitutes"))
- address@hidden)
-
- ;; Add 'lsof' (for the GC) and 'lsh' (for offloading) to the
- ;; daemon's $PATH.
- #:environment-variables
- (list (string-append "PATH=" #$lsof "/bin:" #$lsh "/bin"))))
- (stop #~(make-kill-destructor))
- (user-accounts (guix-build-accounts build-accounts
- #:group builder-group))
- (user-groups (list (user-group
- (name builder-group)
- (system? #t)
-
- ;; Use a fixed GID so that we can create the
- ;; store with the right owner.
- (id 30000))))
- (activate activate)))
+(define-record-type* <guix-configuration>
+ guix-configuration make-guix-configuration
+ guix-configuration?
+ (guix guix-configuration-guix ;<package>
+ (default guix))
+ (build-group guix-configuration-build-group ;string
+ (default "guixbuild"))
+ (build-accounts guix-configuration-build-accounts ;integer
+ (default 10))
+ (authorize-key? guix-configuration-authorize-key? ;Boolean
+ (default #t))
+ (use-substitutes? guix-configuration-use-substitutes? ;Boolean
+ (default #t))
+ (extra-options guix-configuration-extra-options ;list of strings
+ (default '()))
+ (lsof guix-configuration-lsof ;<package>
+ (default lsof))
+ (lsh guix-configuration-lsh ;<package>
+ (default lsh)))
+
+(define %default-guix-configuration
+ (guix-configuration))
+
+(define (guix-dmd-service config)
+ "Return a <dmd-service> for the Guix daemon service with CONFIG."
+ (match config
+ (($ <guix-configuration> guix build-group build-accounts authorize-key?
+ use-substitutes? extra-options lsof lsh)
+ (list (dmd-service
+ (documentation "Run the Guix daemon.")
+ (provision '(guix-daemon))
+ (requirement '(user-processes))
+ (start
+ #~(make-forkexec-constructor
+ (list (string-append #$guix "/bin/guix-daemon")
+ "--build-users-group" #$build-group
+ #$@(if use-substitutes?
+ '()
+ '("--no-substitutes"))
+ address@hidden)
+
+ ;; Add 'lsof' (for the GC) and 'lsh' (for offloading) to the
+ ;; daemon's $PATH.
+ #:environment-variables
+ (list (string-append "PATH=" #$lsof "/bin:" #$lsh "/bin"))))
+ (stop #~(make-kill-destructor)))))))
+
+(define (guix-accounts config)
+ "Return the user accounts and user groups for CONFIG."
+ (match config
+ (($ <guix-configuration> _ build-group build-accounts)
+ (cons (user-group
+ (name build-group)
+ (system? #t)
+
+ ;; Use a fixed GID so that we can create the store with the right
+ ;; owner.
+ (id 30000))
+ (guix-build-accounts build-accounts
+ #:group build-group)))))
+
+(define (guix-activation config)
+ "Return the activation gexp for CONFIG."
+ (match config
+ (($ <guix-configuration> guix build-group build-accounts authorize-key?)
+ ;; Assume that the store has BUILD-GROUP as its group. We could
+ ;; otherwise call 'chown' here, but the problem is that on a COW unionfs,
+ ;; chown leads to an entire copy of the tree, which is a bad idea.
+
+ ;; Optionally authorize hydra.gnu.org's key.
+ (and authorize-key?
+ (hydra-key-authorization guix)))))
+
+(define guix-service-type
+ (service-type
+ (name 'guix)
+ (extensions
+ (list (service-extension dmd-root-service-type
+ guix-dmd-service)
+ (service-extension account-service-type
+ guix-accounts)
+ (service-extension activation-service-type
+ guix-activation)))))
+
+(define* (guix-service #:optional (config %default-guix-configuration))
+ "Return a service that runs the Guix build daemon according to
address@hidden"
+ (service (type guix-service-type)
+ (parameters config)))
(define (udev-rules-union packages)
"Return the union of the @code{lib/udev/rules.d} directories found in each
@@ -724,9 +855,16 @@ item of @var{packages}."
KERNEL==\"kvm\", GROUP=\"kvm\", MODE=\"0660\"\n" port))))
#:modules '((guix build utils))))
-(define* (udev-service #:key (udev eudev) (rules '()))
- "Run @var{udev}, which populates the @file{/dev} directory dynamically. Get
-extra rules from the packages listed in @var{rules}."
+(define udev-service-type
+ (service-type (name 'udev)
+ (extensions
+ (list (service-extension
+ dmd-root-service-type
+ (lambda (rules)
+ (list (udev-rules->dmd-service rules))))))
+ (extend concatenate))) ;concatenate the list of rules
+
+(define* (udev-rules->dmd-service rules #:key (udev eudev))
(let* ((rules (udev-rules-union (cons* udev
(kvm-udev-rule)
rules)))
@@ -736,7 +874,7 @@ extra rules from the packages listed in @var{rules}."
(format port
"udev_rules=\"~a/lib/udev/rules.d\"\n"
#$rules))))))
- (service
+ (dmd-service
(provision '(udev))
;; Udev needs /dev to be a 'devtmpfs' mount so that new device nodes can
@@ -801,41 +939,61 @@ extra rules from the packages listed in @var{rules}."
(stop #~(make-kill-destructor))
;; When halting the system, 'udev' is actually killed by
- ;; 'user-processes', i.e., before its own 'stop' method was
- ;; called. Thus, make sure it is not respawned.
+ ;; 'user-processes', i.e., before its own 'stop' method was called.
+ ;; Thus, make sure it is not respawned.
(respawn? #f))))
+(define* (udev-service #:key (udev eudev) (rules '()))
+ "Run @var{udev}, which populates the @file{/dev} directory dynamically. Get
+extra rules from the packages listed in @var{rules}."
+ ;; FIXME: #:udev is ignored!
+ (service (type udev-service-type)
+ (parameters rules)))
+
+(define device-mapping-service-type
+ (dmd-service-type
+ (match-lambda
+ ((target open close)
+ (dmd-service
+ (provision (list (symbol-append 'device-mapping- (string->symbol
target))))
+ (requirement '(udev))
+ (documentation "Map a device node using Linux's device mapper.")
+ (start #~(lambda () #$open))
+ (stop #~(lambda _ (not #$close)))
+ (respawn? #f))))))
+
(define (device-mapping-service target open close)
"Return a service that maps device @var{target}, a string such as
@code{\"home\"} (meaning @code{/dev/mapper/home}). Evaluate @var{open}, a
gexp, to open it, and evaluate @var{close} to close it."
- (service
- (provision (list (symbol-append 'device-mapping- (string->symbol target))))
- (requirement '(udev))
- (documentation "Map a device node using Linux's device mapper.")
- (start #~(lambda () #$open))
- (stop #~(lambda _ (not #$close)))
- (respawn? #f)))
+ (service (type device-mapping-service-type)
+ (parameters (list target open close))))
+
+(define swap-service-type
+ (dmd-service-type
+ (lambda (device)
+ (define requirement
+ (if (string-prefix? "/dev/mapper/" device)
+ (list (symbol-append 'device-mapping-
+ (string->symbol (basename device))))
+ '()))
+
+ (dmd-service
+ (provision (list (symbol-append 'swap- (string->symbol device))))
+ (requirement `(udev ,@requirement))
+ (documentation "Enable the given swap device.")
+ (start #~(lambda ()
+ (restart-on-EINTR (swapon #$device))
+ #t))
+ (stop #~(lambda _
+ (restart-on-EINTR (swapoff #$device))
+ #f))
+ (respawn? #f)))))
(define (swap-service device)
"Return a service that uses @var{device} as a swap device."
- (define requirement
- (if (string-prefix? "/dev/mapper/" device)
- (list (symbol-append 'device-mapping-
- (string->symbol (basename device))))
- '()))
-
- (service
- (provision (list (symbol-append 'swap- (string->symbol device))))
- (requirement `(udev ,@requirement))
- (documentation "Enable the given swap device.")
- (start #~(lambda ()
- (restart-on-EINTR (swapon #$device))
- #t))
- (stop #~(lambda _
- (restart-on-EINTR (swapoff #$device))
- #f))
- (respawn? #f)))
+ (service (type swap-service-type)
+ (parameters device)))
(define %base-services
;; Convenience variable holding the basic services.
@@ -861,8 +1019,8 @@ This is the GNU operating system, welcome!\n\n")))
(mingetty-service (mingetty-configuration
(tty "tty6") (motd motd)))
- (static-networking-service "lo" "127.0.0.1"
- #:provision '(loopback))
+ ;; (static-networking-service "lo" "127.0.0.1"
+ ;; #:provision '(loopback))
(syslog-service)
(guix-service)
(nscd-service)
diff --git a/gnu/services/dmd.scm b/gnu/services/dmd.scm
index 618df91..74866c6 100644
--- a/gnu/services/dmd.scm
+++ b/gnu/services/dmd.scm
@@ -22,13 +22,20 @@
#: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)
+ #:use-module (gnu packages admin)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
- #:export (dmd-configuration-file))
+ #:export (dmd-root-service-type
+ %dmd-root-service
+ dmd-service-type
+
+ dmd-service
+ dmd-service?))
;;; Commentary:
;;;
@@ -36,6 +43,69 @@
;;;
;;; Code:
+
+(define (dmd-boot-gexp services)
+ (mlet %store-monad ((dmd-conf (dmd-configuration-file services)))
+ (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 dmd.
+ (execl (string-append #$dmd "/bin/dmd")
+ "dmd" "--config" #$dmd-conf)))))
+
+(define dmd-root-service-type
+ (service-type
+ (name 'dmd-root)
+ ;; Extending the root dmd service (aka. PID 1) happens by concatenating the
+ ;; list of services provided by the extensions.
+ (extend concatenate)
+ (extensions (list (service-extension boot-service-type
+ dmd-boot-gexp)))))
+
+(define %dmd-root-service
+ ;; The root dmd service, aka. PID 1.
+ (service
+ (type dmd-root-service-type)
+ (parameters '()))) ;list of <dmd-service>
+
+(define-syntax-rule (dmd-service-type proc)
+ "Return a <service-type> denoting a simple dmd service--i.e., the type for a
+service that extends DMD-ROOT-SERVICE-TYPE and nothing else."
+ (service-type
+ (name 'some-dmd-service)
+ (extensions
+ (list (service-extension dmd-root-service-type
+ (compose list proc))))))
+
+(define-record-type* <dmd-service>
+ dmd-service make-dmd-service
+ dmd-service?
+ (documentation service-documentation ; string
+ (default "[No documentation.]"))
+ (provision service-provision) ; list of symbols
+ (requirement service-requirement ; list of symbols
+ (default '()))
+ (respawn? service-respawn? ; Boolean
+ (default #t))
+ (start service-start) ; g-expression (procedure)
+ (stop service-stop ; g-expression (procedure)
+ (default #~(const #f)))
+ (auto-start? service-auto-start? ; Boolean
+ (default #t)))
+
+
(define (assert-no-duplicates services)
"Raise an error if SERVICES provide the same dmd service more than once.
diff --git a/gnu/system.scm b/gnu/system.scm
index 5eaafed..70a48bf 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -87,8 +87,6 @@
operating-system-locale-directory
operating-system-boot-script
- file-union
-
local-host-aliases
%setuid-programs
%base-packages
@@ -162,41 +160,6 @@
;;;
-;;; Derivation.
-;;;
-
-(define* (file-union name files)
- "Return a derivation that builds a directory containing all of FILES. Each
-item in FILES must be a list where the first element is the file name to use
-in the new directory, and the second element is a gexp denoting the target
-file."
- (define builder
- #~(begin
- (mkdir #$output)
- (chdir #$output)
- #$@(map (match-lambda
- ((target source)
- #~(symlink #$source #$target)))
- files)))
-
- (gexp->derivation name builder))
-
-(define (directory-union name things)
- "Return a directory that is the union of THINGS."
- (match things
- ((one)
- ;; Only one thing; return it.
- (with-monad %store-monad (return one)))
- (_
- (gexp->derivation name
- #~(begin
- (use-modules (guix build union))
- (union-build #$output '#$things))
- #:modules '((guix build union))
- #:local-build? #t))))
-
-
-;;;
;;; Services.
;;;
@@ -244,18 +207,7 @@ as 'needed-for-boot'."
(string->symbol (mapped-device-target md))))
(device-mappings fs))))
- (map (lambda (fs)
- (match fs
- (($ <file-system> device title target type flags opts
- #f check? create?)
- (file-system-service device target type
- #:title title
- #:requirements (requirements fs)
- #:check? check?
- #:create-mount-point? create?
- #:options opts
- #:flags flags))))
- file-systems))
+ (map file-system-service file-systems))
(define (mapped-device-user device file-systems)
"Return a file system among FILE-SYSTEMS that uses DEVICE, or #f."
@@ -315,10 +267,20 @@ bookkeeping."
(unmount (user-unmount-service known-fs))
(swaps (swap-services os))
(procs (user-processes-service
- (map (compose first service-provision)
- other-fs)))
+ (map service-parameters other-fs)))
(host-name (host-name-service (operating-system-host-name os))))
- (cons* host-name procs root-fs unmount
+ (cons* %boot-service
+
+ ;; %DMD-ROOT-SERVICE must come first so that the gexp that execs
+ ;; dmd comes last in the boot script (XXX).
+ %dmd-root-service %activation-service
+
+ (pam-root-service (operating-system-pam-services os))
+ (account-service (append (operating-system-accounts os)
+ (operating-system-groups os))
+ (operating-system-skeletons os))
+ (operating-system-etc-service os)
+ host-name procs root-fs unmount
(append other-fs mappings swaps))))
(define (operating-system-services os)
@@ -437,29 +399,24 @@ on SHELLS. /etc/shells is used by xterm, polkit, and
other programs."
(newline port))
shells))))))
-(define* (etc-directory #:key
- (locale "C") (timezone "Europe/Paris")
- (issue "Hello!\n")
- (skeletons '())
- (pam-services '())
- (profile "/run/current-system/profile")
- hosts-file nss (shells '())
- (sudoers-file (plain-file "sudoers" "")))
- "Return a derivation that builds the static part of the /etc directory."
- (mlet* %store-monad
- ((pam.d -> (pam-services->directory pam-services))
- (login.defs (text-file "login.defs" "# Empty for now.\n"))
- (shells (shells-file shells))
- (emacs (emacs-site-directory))
- (issue (text-file "issue" issue))
- (nsswitch (text-file "nsswitch.conf"
- (name-service-switch->string nss)))
+(define* (operating-system-etc-service os)
+ "Return a <service> that builds containing the static part of the /etc
+directory."
+ (let
+ ((login.defs (plain-file "login.defs" "# Empty for now.\n"))
+ ;; FIXME: These two are missing.
+ ;; (shells (shells-file shells))
+ ;; (emacs (emacs-site-directory))
+ (issue (plain-file "issue" (operating-system-issue os)))
+ (nsswitch (plain-file "nsswitch.conf"
+ (name-service-switch->string
+ (operating-system-name-service-switch os))))
;; Startup file for POSIX-compliant login shells, which set system-wide
;; environment variables.
- (profile (text-file* "profile" "\
-export LANG=\"" locale "\"
-export TZ=\"" timezone "\"
+ (profile (mixed-text-file "profile" "\
+export LANG=\"" (operating-system-locale os) "\"
+export TZ=\"" (operating-system-timezone os) "\"
export TZDIR=\"" tzdata "/share/zoneinfo\"
# Tell 'modprobe' & co. where to look for modules.
@@ -516,7 +473,7 @@ then
fi
"))
- (bashrc (text-file "bashrc" "\
+ (bashrc (plain-file "bashrc" "\
# Bash-specific initialization.
# The 'bash-completion' package.
@@ -526,25 +483,23 @@ then
# completion loader that searches its own completion files as well
# as those in ~/.guix-profile and /run/current-system/profile.
source /run/current-system/profile/etc/profile.d/bash_completion.sh
-fi\n"))
- (skel -> (skeleton-directory skeletons)))
- (file-union "etc"
- `(("services" ,#~(string-append #$net-base "/etc/services"))
- ("protocols" ,#~(string-append #$net-base "/etc/protocols"))
- ("rpc" ,#~(string-append #$net-base "/etc/rpc"))
- ("emacs" ,#~#$emacs)
- ("pam.d" ,#~#$pam.d)
- ("login.defs" ,#~#$login.defs)
- ("issue" ,#~#$issue)
- ("nsswitch.conf" ,#~#$nsswitch)
- ("skel" ,#~#$skel)
- ("shells" ,#~#$shells)
- ("profile" ,#~#$profile)
- ("bashrc" ,#~#$bashrc)
- ("hosts" ,#~#$hosts-file)
- ("localtime" ,#~(string-append #$tzdata "/share/zoneinfo/"
- #$timezone))
- ("sudoers" ,sudoers-file)))))
+fi\n")))
+ (etc-service
+ `(("services" ,#~(string-append #$net-base "/etc/services"))
+ ("protocols" ,#~(string-append #$net-base "/etc/protocols"))
+ ("rpc" ,#~(string-append #$net-base "/etc/rpc"))
+ ;; ("emacs" ,#~#$emacs)
+ ("login.defs" ,#~#$login.defs)
+ ("issue" ,#~#$issue)
+ ("nsswitch.conf" ,#~#$nsswitch)
+ ;; ("shells" ,#~#$shells)
+ ("profile" ,#~#$profile)
+ ("bashrc" ,#~#$bashrc)
+ ("hosts" ,#~#$(or (operating-system-hosts-file os)
+ (default-/etc/hosts (operating-system-host-name os))))
+ ("localtime" ,#~(string-append #$tzdata "/share/zoneinfo/"
+ #$(operating-system-timezone os)))
+ ("sudoers" ,(operating-system-sudoers-file os))))))
(define (operating-system-profile os)
"Return a derivation that builds the system profile of OS."
@@ -570,9 +525,7 @@ fi\n"))
(operating-system-users os)
(cons %root-account (operating-system-users os))))
- (append users
- (append-map service-user-accounts
- (operating-system-services os))))
+ users)
(define (maybe-string->file file-name thing)
"If THING is a string, return a <plain-file> with THING as its content.
@@ -607,31 +560,9 @@ use 'plain-file' instead~%")
(define (operating-system-etc-directory os)
"Return that static part of the /etc directory of OS."
- (mlet* %store-monad
- ((services -> (operating-system-services os))
- (pam-services ->
- ;; Services known to PAM.
- (append (operating-system-pam-services os)
- (append-map service-pam-services services)))
- (profile-drv (operating-system-profile os))
- (skeletons (operating-system-skeletons os))
- (/etc/hosts (maybe-file->monadic
- "hosts"
- (or (operating-system-hosts-file os)
- (default-/etc/hosts (operating-system-host-name
os)))))
- (shells -> (user-shells os)))
- (etc-directory #:pam-services pam-services
- #:skeletons skeletons
- #:issue (operating-system-issue os)
- #:locale (operating-system-locale os)
- #:nss (operating-system-name-service-switch os)
- #:timezone (operating-system-timezone os)
- #:hosts-file /etc/hosts
- #:shells shells
- #:sudoers-file (maybe-string->file
- "sudoers"
- (operating-system-sudoers-file os))
- #:profile profile-drv)))
+ (etc-directory
+ (fold-services (operating-system-services os)
+ #:target-type etc-service-type)))
(define %setuid-programs
;; Default set of setuid-root programs.
@@ -652,176 +583,13 @@ use 'plain-file' instead~%")
root ALL=(ALL) ALL
%wheel ALL=(ALL) ALL\n"))
-(define (user-group->gexp group)
- "Turn GROUP, a <user-group> object, into a list-valued gexp suitable for
-'active-groups'."
- #~(list #$(user-group-name group)
- #$(user-group-password group)
- #$(user-group-id group)
- #$(user-group-system? group)))
-
-(define (user-account->gexp account)
- "Turn ACCOUNT, a <user-account> object, into a list-valued gexp suitable for
-'activate-users'."
- #~`(#$(user-account-name account)
- #$(user-account-uid account)
- #$(user-account-group account)
- #$(user-account-supplementary-groups account)
- #$(user-account-comment account)
- #$(user-account-home-directory account)
- ,#$(user-account-shell account) ; this one is a gexp
- #$(user-account-password account)
- #$(user-account-system? account)))
-
-(define (modprobe-wrapper)
- "Return a wrapper for the 'modprobe' command that knows where modules live.
-
-This wrapper is typically invoked by the Linux kernel ('call_modprobe', in
-kernel/kmod.c), a situation where the 'LINUX_MODULE_DIRECTORY' environment
-variable is not set---hence the need for this wrapper."
- (let ((modprobe "/run/current-system/profile/bin/modprobe"))
- (gexp->script "modprobe"
- #~(begin
- (setenv "LINUX_MODULE_DIRECTORY"
- "/run/booted-system/kernel/lib/modules")
- (apply execl #$modprobe
- (cons #$modprobe (cdr (command-line))))))))
-
-(define* (operating-system-activation-script os #:key container?)
- "Return the activation script for OS---i.e., the code that \"activates\" the
-stateful part of OS, including user accounts and groups, special directories,
-etc."
- (define %modules
- '((gnu build activation)
- (gnu build linux-boot)
- (gnu build linux-modules)
- (gnu build file-systems)
- (guix build utils)
- (guix build syscalls)
- (guix elf)))
-
- (define (service-activations services)
- ;; Return the activation scripts for SERVICES.
- (let ((gexps (filter-map service-activate services)))
- (sequence %store-monad (map (cut gexp->file "activate-service.scm" <>)
- gexps))))
-
- (mlet* %store-monad ((services -> (operating-system-services os))
- (actions (service-activations services))
- (etc (operating-system-etc-directory os))
- (modules (imported-modules %modules))
- (compiled (compiled-modules %modules))
- (modprobe (modprobe-wrapper))
- (firmware (directory-union
- "firmware" (operating-system-firmware os)))
- (accounts -> (operating-system-accounts os)))
- (define setuid-progs
- (operating-system-setuid-programs os))
-
- (define user-specs
- (map user-account->gexp accounts))
-
- (define groups
- (append (operating-system-groups os)
- (append-map service-user-groups services)))
-
- (define group-specs
- (map user-group->gexp groups))
-
- (assert-valid-users/groups accounts groups)
-
- (gexp->file "activate"
- #~(begin
- (eval-when (expand load eval)
- ;; Make sure 'use-modules' below succeeds.
- (set! %load-path (cons #$modules %load-path))
- (set! %load-compiled-path
- (cons #$compiled %load-compiled-path)))
-
- (use-modules (gnu build activation))
-
- ;; Make sure /bin/sh is valid and current.
- (activate-/bin/sh
- (string-append #$(canonical-package bash)
- "/bin/sh"))
-
- ;; Populate /etc.
- (activate-etc #$etc)
-
- ;; Add users and user groups.
- (setenv "PATH"
- (string-append #$(@ (gnu packages admin) shadow)
- "/sbin"))
- (activate-users+groups (list address@hidden)
- (list address@hidden))
-
- ;; Activate setuid programs.
- (activate-setuid-programs (list address@hidden))
-
- ;; Tell the kernel to use our 'modprobe' command.
- (activate-modprobe #$modprobe)
-
- ;; Tell the kernel where firmware is, unless we are
- ;; activating a container.
- #$@(if container?
- #~()
- ;; Tell the kernel where firmware is.
- #~((activate-firmware
- (string-append #$firmware "/lib/firmware"))
- ;; Let users debug their own processes!
- (activate-ptrace-attach)))
-
- ;; Run the services' activation snippets.
- ;; TODO: Use 'load-compiled'.
- (for-each primitive-load '#$actions)
-
- ;; Set up /run/current-system.
- (activate-current-system)))))
-
-(define* (operating-system-boot-script os #:key container?)
+(define* (operating-system-boot-script os)
"Return the boot script for OS---i.e., the code started by the initrd once
we're running in the final root. When CONTAINER? is true, skip all
hardware-related operations as necessary when booting a Linux container."
- (mlet* %store-monad ((services -> (operating-system-services os))
- (activate (operating-system-activation-script os))
- (dmd-conf (dmd-configuration-file services)))
- (gexp->file "boot"
- #~(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.
- (false-if-exception (delete-file-recursively "/tmp"))
- (false-if-exception (delete-file-recursively "/var/run"))
- (false-if-exception (mkdir "/tmp"))
- (false-if-exception (chmod "/tmp" #o1777))
- (false-if-exception (mkdir "/var/run"))
- (false-if-exception (chmod "/var/run" #o755))
-
- ;; Activate the system.
- ;; TODO: Use 'load-compiled'.
- (primitive-load #$activate)
-
- ;; 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 dmd.
- (execl (string-append #$dmd "/bin/dmd")
- "dmd" "--config" #$dmd-conf)))))
+ (let ((boot (fold-services (operating-system-services os))))
+ ;; This is the script as a monadic value.
+ (service-parameters boot)))
(define (operating-system-root-file-system os)
"Return the root file system of OS."
@@ -908,19 +676,20 @@ this file is the reconstruction of GRUB menu entries for
old configurations."
"Return a derivation that builds OS."
(mlet* %store-monad
((profile (operating-system-profile os))
- (etc (operating-system-etc-directory os))
+ (etc -> (operating-system-etc-directory os))
(boot (operating-system-boot-script os))
(kernel -> (operating-system-kernel os))
(initrd (operating-system-initrd-file os))
(locale (operating-system-locale-directory os))
(params (operating-system-parameters-file os)))
- (file-union "system"
- `(("boot" ,#~#$boot)
- ("kernel" ,#~#$kernel)
- ("parameters" ,#~#$params)
- ("initrd" ,initrd)
- ("profile" ,#~#$profile)
- ("locale" ,#~#$locale) ;used by libc
- ("etc" ,#~#$etc)))))
+ (lower-object
+ (file-union "system"
+ `(("boot" ,#~#$boot)
+ ("kernel" ,#~#$kernel)
+ ("parameters" ,#~#$params)
+ ("initrd" ,initrd)
+ ("profile" ,#~#$profile)
+ ("locale" ,#~#$locale) ;used by libc
+ ("etc" ,#~#$etc))))))
;;; system.scm ends here
diff --git a/gnu/system/examples/bare-bones.tmpl
b/gnu/system/examples/bare-bones.tmpl
index dc5cfc8..715ea75 100644
--- a/gnu/system/examples/bare-bones.tmpl
+++ b/gnu/system/examples/bare-bones.tmpl
@@ -2,7 +2,8 @@
;; for a "bare bones" setup, with no X11 display server.
(use-modules (gnu))
-(use-service-modules networking ssh)
+;; FIXME: Re-add this later.
+;; (use-service-modules networking ssh)
(use-package-modules admin)
(operating-system
@@ -42,6 +43,5 @@
;; Add services to the baseline: a DHCP client and
;; an SSH server.
- (services (cons* (dhcp-client-service)
- (lsh-service #:port-number 2222)
- %base-services)))
+ ;; FIXME: re-add them later.
+ (services %base-services))
diff --git a/gnu/system/linux.scm b/gnu/system/linux.scm
index 10e72e9..21bb9f5 100644
--- a/gnu/system/linux.scm
+++ b/gnu/system/linux.scm
@@ -20,6 +20,7 @@
#:use-module (guix records)
#:use-module (guix derivations)
#:use-module (guix gexp)
+ #:use-module (gnu services)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
@@ -28,7 +29,10 @@
pam-entry
pam-services->directory
unix-pam-service
- base-pam-services))
+ base-pam-services
+
+ pam-root-service-type
+ pam-root-service))
;;; Commentary:
;;;
@@ -98,8 +102,8 @@ dumped in /etc/pam.d/NAME, where NAME is the name of
SERVICE."
(mkdir #$output)
(for-each (match-lambda
- ((name file)
- (symlink file (string-append #$output "/" name))))
+ ((name file)
+ (symlink file (string-append #$output "/" name))))
;; Since <pam-service> objects cannot be compared with
;; 'equal?' since they contain gexps, which contain
@@ -188,4 +192,24 @@ authenticate to run COMMAND."
'("useradd" "userdel" "usermod"
"groupadd" "groupdel" "groupmod"))))
+
+;;;
+;;; PAM root service.
+;;;
+
+(define (/etc-entry services)
+ `(("pam.d" ,(pam-services->directory services))))
+
+(define pam-root-service-type
+ (service-type (name 'pam)
+ (extensions (list (service-extension etc-service-type
+ /etc-entry)))
+ (extend concatenate)))
+
+(define (pam-root-service base)
+ "The \"root\" PAM service, which collects <pam-service> instance and turns
+them into a /etc/pam.d directory, including the <pam-service> listed in BASE."
+ (service (type pam-root-service-type)
+ (parameters base)))
+
;;; linux.scm ends here
diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm
index ddd5f66..87f68ce 100644
--- a/gnu/system/shadow.scm
+++ b/gnu/system/shadow.scm
@@ -22,12 +22,14 @@
#:use-module (guix store)
#:use-module (guix sets)
#:use-module (guix ui)
+ #:use-module (gnu services)
#:use-module ((gnu system file-systems)
#:select (%tty-gid))
#:use-module ((gnu packages admin)
#:select (shadow))
#:use-module (gnu packages bash)
#:use-module (gnu packages guile-wm)
+ #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
@@ -54,7 +56,9 @@
skeleton-directory
%base-groups
%base-user-accounts
- assert-valid-users/groups))
+
+ account-service-type
+ account-service))
;;; Commentary:
;;;
@@ -87,31 +91,42 @@
(system? user-group-system? ; Boolean
(default #f)))
+;; Configuration of the whole user account system.
+(define-record-type* <account-configuration>
+ account-configuration make-account-configuration
+ account-configuration?
+ (users account-configuration-users)
+ (groups account-configuration-groups)
+ (skeletons account-configuration-skeletons
+ (default (default-skeletons)))
+ (shadow account-configuration-shadow
+ (default (@ (gnu packages admin) shadow))))
+
(define %base-groups
;; Default set of groups.
(let-syntax ((system-group (syntax-rules ()
((_ args ...)
(user-group (system? #t) args ...)))))
(list (system-group (name "root") (id 0))
- (system-group (name "wheel")) ; root-like users
- (system-group (name "users")) ; normal users
- (system-group (name "nogroup")) ; for daemons etc.
+ (system-group (name "wheel")) ; root-like users
+ (system-group (name "users")) ; normal users
+ (system-group (name "nogroup")) ; for daemons etc.
;; The following groups are conventionally used by things like udev
to
;; control access to hardware devices.
(system-group (name "tty") (id %tty-gid))
(system-group (name "dialout"))
(system-group (name "kmem"))
- (system-group (name "input")) ; input devices, from udev
+ (system-group (name "input")) ; input devices, from udev
(system-group (name "video"))
(system-group (name "audio"))
- (system-group (name "netdev")) ; used in avahi-dbus.conf
+ (system-group (name "netdev")) ; used in avahi-dbus.conf
(system-group (name "lp"))
(system-group (name "disk"))
(system-group (name "floppy"))
(system-group (name "cdrom"))
(system-group (name "tape"))
- (system-group (name "kvm"))))) ; for /dev/kvm
+ (system-group (name "kvm"))))) ; for /dev/kvm
(define %base-user-accounts
;; List of standard user accounts. Note that "root" is a special case, so
@@ -224,4 +239,80 @@ of user '~a' is undeclared")
(user-account-supplementary-groups user)))
users)))
+
+;;;
+;;; Service.
+;;;
+
+(define (user-group->gexp group)
+ "Turn GROUP, a <user-group> object, into a list-valued gexp suitable for
+'active-groups'."
+ #~(list #$(user-group-name group)
+ #$(user-group-password group)
+ #$(user-group-id group)
+ #$(user-group-system? group)))
+
+(define (user-account->gexp account)
+ "Turn ACCOUNT, a <user-account> object, into a list-valued gexp suitable for
+'activate-users'."
+ #~`(#$(user-account-name account)
+ #$(user-account-uid account)
+ #$(user-account-group account)
+ #$(user-account-supplementary-groups account)
+ #$(user-account-comment account)
+ #$(user-account-home-directory account)
+ ,#$(user-account-shell account) ; this one is a gexp
+ #$(user-account-password account)
+ #$(user-account-system? account)))
+
+(define (account-activation accounts+groups)
+ "Return a gexp that activates ACCOUNTS+GROUPS, a list of <user-account> and
+<user-group> objects. Raise an error if a user account refers to a undefined
+group."
+ (define accounts
+ (filter user-account? accounts+groups))
+
+ (define user-specs
+ (map user-account->gexp accounts))
+
+ (define groups
+ (filter user-group? accounts+groups))
+
+ (define group-specs
+ (map user-group->gexp groups))
+
+ (assert-valid-users/groups accounts groups)
+
+ ;; Add users and user groups.
+ #~(begin
+ (setenv "PATH"
+ (string-append #$(@ (gnu packages admin) shadow) "/sbin"))
+ (activate-users+groups (list address@hidden)
+ (list address@hidden))))
+
+(define (etc-skel arguments)
+ "Filter out among ARGUMENTS things corresponding to skeletons, and return
+the /etc/skel directory for those."
+ (let ((skels (filter pair? arguments)))
+ `(("skel" ,(skeleton-directory skels)))))
+
+(define account-service-type
+ (service-type (name 'account)
+
+ ;; Concatenate <user-account>, <user-group>, and skeleton
+ ;; lists.
+ (extend concatenate)
+
+ (extensions
+ (list (service-extension activation-service-type
+ account-activation)
+ (service-extension etc-service-type
+ etc-skel)))))
+
+(define (account-service accounts+groups skeletons)
+ "Return a <service> that takes care of user accounts and user groups, with
+ACCOUNTS+GROUPS as its initial list of accounts and groups."
+ (service (type account-service-type)
+ (parameters (append skeletons accounts+groups))))
+
;;; shadow.scm ends here
- 03/13: gexp: Add 'mixed-text-file'., (continued)
- 03/13: gexp: Add 'mixed-text-file'., Ludovic Courtès, 2015/09/21
- 04/13: services: 'mingetty-service' no longer takes monadic values., Ludovic Courtès, 2015/09/21
- 07/13: PRELIM: services: nscd-service: Fit everything into <nscd-configuration>., Ludovic Courtès, 2015/09/21
- 06/13: PRELIM: services: mingetty-service: Use <mingetty-configuration> objects., Ludovic Courtès, 2015/09/21
- 09/13: system: pam: Use 'computed-file' instead of 'gexp->derivation'., Ludovic Courtès, 2015/09/21
- 08/13: gexp: Add 'scheme-file'., Ludovic Courtès, 2015/09/21
- 11/13: system: Account skeleton API is non-monadic., Ludovic Courtès, 2015/09/21
- 10/13: guix system: Add '--derivation'., Ludovic Courtès, 2015/09/21
- 12/13: records: Add 'define-record-type†'., Ludovic Courtès, 2015/09/21
- 05/13: system: Make service procedures non-monadic., Ludovic Courtès, 2015/09/21
- 13/13: PRELIM: services: Introduce extensible abstract services.,
Ludovic Courtès <=