diff options
Diffstat (limited to 'gnu/services')
| -rw-r--r-- | gnu/services/avahi.scm | 144 | ||||
| -rw-r--r-- | gnu/services/base.scm | 1255 | ||||
| -rw-r--r-- | gnu/services/databases.scm | 164 | ||||
| -rw-r--r-- | gnu/services/dbus.scm | 178 | ||||
| -rw-r--r-- | gnu/services/desktop.scm | 649 | ||||
| -rw-r--r-- | gnu/services/dmd.scm | 78 | ||||
| -rw-r--r-- | gnu/services/lirc.scm | 83 | ||||
| -rw-r--r-- | gnu/services/networking.scm | 555 | ||||
| -rw-r--r-- | gnu/services/ssh.scm | 180 | ||||
| -rw-r--r-- | gnu/services/web.scm | 111 | ||||
| -rw-r--r-- | gnu/services/xorg.scm | 207 |
11 files changed, 2205 insertions, 1399 deletions
diff --git a/gnu/services/avahi.scm b/gnu/services/avahi.scm index a3ca5ab6fb..b576c395ff 100644 --- a/gnu/services/avahi.scm +++ b/gnu/services/avahi.scm @@ -18,11 +18,13 @@ (define-module (gnu services avahi) #:use-module (gnu services) + #:use-module (gnu services base) + #:use-module (gnu services dmd) + #:use-module (gnu services dbus) #:use-module (gnu system shadow) #:use-module (gnu packages avahi) #:use-module (gnu packages admin) - #:use-module (guix monads) - #:use-module (guix store) + #:use-module (guix records) #:use-module (guix gexp) #:export (avahi-service)) @@ -33,27 +35,91 @@ ;;; ;;; Code: -(define* (configuration-file #:key host-name publish? - ipv4? ipv6? wide-area? domains-to-browse) - "Return an avahi-daemon configuration file." + ;; TODO: Export. +(define-record-type* <avahi-configuration> + avahi-configuration make-avahi-configuration + avahi-configuration? + (avahi avahi-configuration-avahi ;<package> + (default avahi)) + (host-name avahi-configuration-host-name) ;string + (publish? avahi-configuration-publish?) ;Boolean + (ipv4? avahi-configuration-ipv4?) ;Boolean + (ipv6? avahi-configuration-ipv6?) ;Boolean + (wide-area? avahi-configuration-wide-area?) ;Boolean + (domains-to-browse avahi-configuration-domains-to-browse)) ;list of strings + +(define* (configuration-file config) + "Return an avahi-daemon configuration file based on CONFIG, an +<avahi-configuration>." (define (bool value) (if value "yes\n" "no\n")) - (text-file "avahi-daemon.conf" - (string-append - "[server]\n" - (if host-name - (string-append "host-name=" host-name "\n") - "") - - "browse-domains=" (string-join domains-to-browse) - "\n" - "use-ipv4=" (bool ipv4?) - "use-ipv6=" (bool ipv6?) - "[wide-area]\n" - "enable-wide-area=" (bool wide-area?) - "[publish]\n" - "disable-publishing=" (bool (not publish?))))) + (define host-name (avahi-configuration-host-name config)) + + (plain-file "avahi-daemon.conf" + (string-append + "[server]\n" + (if host-name + (string-append "host-name=" host-name "\n") + "") + + "browse-domains=" (string-join + (avahi-configuration-domains-to-browse + config)) + "\n" + "use-ipv4=" (bool (avahi-configuration-ipv4? config)) + "use-ipv6=" (bool (avahi-configuration-ipv6? config)) + "[wide-area]\n" + "enable-wide-area=" (bool (avahi-configuration-wide-area? config)) + "[publish]\n" + "disable-publishing=" + (bool (not (avahi-configuration-publish? config)))))) + +(define %avahi-accounts + ;; Account and group for the Avahi daemon. + (list (user-group (name "avahi") (system? #t)) + (user-account + (name "avahi") + (group "avahi") + (system? #t) + (comment "Avahi daemon user") + (home-directory "/var/empty") + (shell #~(string-append #$shadow "/sbin/nologin"))))) + +(define %avahi-activation + ;; Activation gexp. + #~(begin + (use-modules (guix build utils)) + (mkdir-p "/var/run/avahi-daemon"))) + +(define (avahi-dmd-service config) + "Return a list of <dmd-service> for CONFIG." + (let ((config (configuration-file config)) + (avahi (avahi-configuration-avahi config))) + (list (dmd-service + (documentation "Run the Avahi mDNS/DNS-SD responder.") + (provision '(avahi-daemon)) + (requirement '(dbus-system networking)) + + (start #~(make-forkexec-constructor + (list (string-append #$avahi "/sbin/avahi-daemon") + "--syslog" "-f" #$config))) + (stop #~(make-kill-destructor)))))) + +(define avahi-service-type + (service-type (name 'avahi) + (extensions + (list (service-extension dmd-root-service-type + avahi-dmd-service) + (service-extension dbus-root-service-type + (compose list + avahi-configuration-avahi)) + (service-extension account-service-type + (const %avahi-accounts)) + (service-extension activation-service-type + (const %avahi-activation)) + (service-extension nscd-service-type + (const (list nss-mdns))))))) (define* (avahi-service #:key (avahi avahi) host-name @@ -76,37 +142,11 @@ When @var{wide-area?} is true, DNS-SD over unicast DNS is enabled. Boolean values @var{ipv4?} and @var{ipv6?} determine whether to use IPv4/IPv6 sockets." - (mlet %store-monad ((config (configuration-file #:host-name host-name - #:publish? publish? - #:ipv4? ipv4? - #:ipv6? ipv6? - #:wide-area? wide-area? - #:domains-to-browse - domains-to-browse))) - (return - (service - (documentation "Run the Avahi mDNS/DNS-SD responder.") - (provision '(avahi-daemon)) - (requirement '(dbus-system networking)) - - (start #~(make-forkexec-constructor - (list (string-append #$avahi "/sbin/avahi-daemon") - "--syslog" "-f" #$config))) - (stop #~(make-kill-destructor)) - (activate #~(begin - (use-modules (guix build utils)) - (mkdir-p "/var/run/avahi-daemon"))) - - (user-groups (list (user-group - (name "avahi") - (system? #t)))) - (user-accounts (list (user-account - (name "avahi") - (group "avahi") - (system? #t) - (comment "Avahi daemon user") - (home-directory "/var/empty") - (shell - #~(string-append #$shadow "/sbin/nologin"))))))))) + (service avahi-service-type + (avahi-configuration + (avahi avahi) (host-name host-name) + (publish? publish?) (ipv4? ipv4?) (ipv6? ipv6?) + (wide-area? wide-area?) + (domains-to-browse domains-to-browse)))) ;;; avahi.scm ends here diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 7f37b3da00..adafe1b55e 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 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)) @@ -35,7 +37,6 @@ #:use-module ((gnu build file-systems) #:select (mount-flags->bit-mask)) #:use-module (guix gexp) - #:use-module (guix monads) #:use-module (guix records) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -50,7 +51,11 @@ host-name-service console-keymap-service console-font-service + udev-service-type udev-service + + mingetty-configuration + mingetty-configuration? mingetty-service %nscd-default-caches @@ -62,9 +67,14 @@ nscd-cache nscd-cache? + nscd-service-type nscd-service syslog-service + + guix-configuration + guix-configuration? guix-service + %base-services)) ;;; Commentary: @@ -74,117 +84,136 @@ ;;; ;;; Code: + +;;; +;;; File systems. +;;; + +(define %root-file-system-dmd-service + (dmd-service + (documentation "Take care of the root file system.") + (provision '(root-file-system)) + (start #~(const #t)) + (stop #~(lambda _ + ;; Return #f if successfully stopped. + (sync) + + (call-with-blocked-asyncs + (lambda () + (let ((null (%make-void-port "w"))) + ;; Close 'dmd.log'. + (display "closing log\n") + ;; XXX: Ideally we'd use 'stop-logging', but that one + ;; doesn't actually close the port as of dmd 0.1. + (close-port (@@ (dmd comm) log-output-port)) + (set! (@@ (dmd comm) log-output-port) null) + + ;; Redirect the default output ports.. + (set-current-output-port null) + (set-current-error-port null) + + ;; Close /dev/console. + (for-each close-fdes '(0 1 2)) + + ;; At this point, there are no open files left, so the + ;; root file system can be re-mounted read-only. + (mount #f "/" #f + (logior MS_REMOUNT MS_RDONLY) + #:update-mtab? #f) + + #f))))) + (respawn? #f))) + +(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." - (with-monad %store-monad - (return - (service - (documentation "Take care of the root file system.") - (provision '(root-file-system)) - (start #~(const #t)) - (stop #~(lambda _ - ;; Return #f if successfully stopped. - (sync) - - (call-with-blocked-asyncs - (lambda () - (let ((null (%make-void-port "w"))) - ;; Close 'dmd.log'. - (display "closing log\n") - ;; XXX: Ideally we'd use 'stop-logging', but that one - ;; doesn't actually close the port as of dmd 0.1. - (close-port (@@ (dmd comm) log-output-port)) - (set! (@@ (dmd comm) log-output-port) null) - - ;; Redirect the default output ports.. - (set-current-output-port null) - (set-current-error-port null) - - ;; Close /dev/console. - (for-each close-fdes '(0 1 2)) - - ;; At this point, there are no open files left, so the - ;; root file system can be re-mounted read-only. - (mount #f "/" #f - (logior MS_REMOUNT MS_RDONLY) - #:update-mtab? #f) - - #f))))) - (respawn? #f))))) - -(define* (file-system-service device target type - #:key (flags '()) (check? #t) - create-mount-point? options (title 'any) - (requirements '())) - "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 -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." - (with-monad %store-monad - (return - (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)))))) - -(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." - (with-monad %store-monad - (return - (service + (service root-file-system-service-type #f)) + +(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(?): Make this an extensible service that takes <file-system> objects + ;; and 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 @var{file-system}, a @code{<file-system>} +object." + (service file-system-service-type 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))) + (cons* "/proc" "/sys" '#$known-mount-points))) ;; Make sure we don't keep the user's mount points busy. (chdir "/") @@ -201,102 +230,124 @@ in KNOWN-MOUNT-POINTS when it is stopped." (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 user-unmount-service-type 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." - (with-monad %store-monad - (return (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)))) + (service user-processes-service-type + (list file-systems grace-delay))) + + +;;; +;;; Console & co. +;;; - (display "all processes have been terminated\n") - #f)) - (respawn? #f))))) +(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}." - (with-monad %store-monad - (return (service - (documentation "Initialize the machine's host name.") - (provision '(host-name)) - (start #~(lambda _ - (sethostname #$name))) - (respawn? #f))))) + (service host-name-service-type name)) (define (unicode-start tty) "Return a gexp to start Unicode support on @var{tty}." @@ -316,108 +367,122 @@ stopped before 'kill' is called." (else (zero? (cdr (waitpid pid)))))))) -(define (console-keymap-service file) - "Return a service to load console keymap from @var{file}." - (with-monad %store-monad - (return - (service - (documentation - (string-append "Load console keymap (loadkeys).")) +(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 console-keymap-service-type 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 @var{font} for that tty (fonts are per virtual console in Linux.)" ;; 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))) - (with-monad %store-monad - (return (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* (mingetty-service tty - #:key - (motd (text-file "motd" "Welcome.\n")) - auto-login - login-program - login-pause? - - ;; Allow empty passwords by default so that - ;; first-time users can log in when the 'root' - ;; account has just been created. - (allow-empty-passwords? #t)) - "Return a service to run mingetty on @var{tty}. - -When @var{allow-empty-passwords?} is true, allow empty log-in password. When -@var{auto-login} is true, it must be a user name under which to log-in -automatically. @var{login-pause?} can be set to @code{#t} in conjunction with -@var{auto-login}, in which case the user will have to press a key before the -login shell is launched. - -When true, @var{login-program} is a gexp or a monadic gexp denoting the name -of the log-in program (the default is the @code{login} program from the Shadow -tool suite.) - -@var{motd} is a monadic value containing a text file to use as -the ``message of the day''." - (mlet %store-monad ((motd motd) - (login-program (cond ((gexp? login-program) - (return login-program)) - ((not login-program) - (return #f)) - (else - login-program)))) - (return - (service - (documentation (string-append "Run mingetty on " 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 console-font-service-type (list tty font))) + +(define-record-type* <mingetty-configuration> + mingetty-configuration make-mingetty-configuration + mingetty-configuration? + (mingetty mingetty-configuration-mingetty ;<package> + (default mingetty)) + (tty mingetty-configuration-tty) ;string + (motd mingetty-configuration-motd ;file-like + (default (plain-file "motd" "Welcome.\n"))) + (auto-login mingetty-auto-login ;string | #f + (default #f)) + (login-program mingetty-login-program ;gexp + (default #f)) + (login-pause? mingetty-login-pause? ;Boolean + (default #f)) + + ;; Allow empty passwords by default so that first-time users can log in when + ;; the 'root' account has just been created. + (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> mingetty 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." + (service mingetty-service-type config)) (define-record-type* <nscd-configuration> nscd-configuration make-nscd-configuration @@ -428,7 +493,11 @@ the ``message of the day''." (default 0)) ;; TODO: See nscd.conf in glibc for other options to add. (caches nscd-configuration-caches ;list of <nscd-cache> - (default %nscd-default-caches))) + (default %nscd-default-caches)) + (name-services nscd-configuration-name-services ;list of <packages> + (default '())) + (glibc nscd-configuration-glibc ;<package> + (default (canonical-package glibc)))) (define-record-type* <nscd-cache> nscd-cache make-nscd-cache nscd-cache? @@ -479,85 +548,115 @@ the ``message of the day''." @code{<nscd-configuration>} object." (define cache->config (match-lambda - (($ <nscd-cache> (= symbol->string database) - positive-ttl negative-ttl size check-files? - persistent? shared? max-size propagate?) - (string-append "\nenable-cache\t" database "\tyes\n" - - "positive-time-to-live\t" database "\t" - (number->string positive-ttl) "\n" - "negative-time-to-live\t" database "\t" - (number->string negative-ttl) "\n" - "suggested-size\t" database "\t" - (number->string size) "\n" - "check-files\t" database "\t" - (if check-files? "yes\n" "no\n") - "persistent\t" database "\t" - (if persistent? "yes\n" "no\n") - "shared\t" database "\t" - (if shared? "yes\n" "no\n") - "max-db-size\t" database "\t" - (number->string max-size) "\n" - "auto-propagate\t" database "\t" - (if propagate? "yes\n" "no\n"))))) + (($ <nscd-cache> (= symbol->string database) + positive-ttl negative-ttl size check-files? + persistent? shared? max-size propagate?) + (string-append "\nenable-cache\t" database "\tyes\n" + + "positive-time-to-live\t" database "\t" + (number->string positive-ttl) "\n" + "negative-time-to-live\t" database "\t" + (number->string negative-ttl) "\n" + "suggested-size\t" database "\t" + (number->string size) "\n" + "check-files\t" database "\t" + (if check-files? "yes\n" "no\n") + "persistent\t" database "\t" + (if persistent? "yes\n" "no\n") + "shared\t" database "\t" + (if shared? "yes\n" "no\n") + "max-db-size\t" database "\t" + (number->string max-size) "\n" + "auto-propagate\t" database "\t" + (if propagate? "yes\n" "no\n"))))) (match config (($ <nscd-configuration> log-file debug-level caches) - (text-file "nscd.conf" - (string-append "\ + (plain-file "nscd.conf" + (string-append "\ # Configuration of libc's name service cache daemon (nscd).\n\n" - (if log-file - (string-append "logfile\t" log-file) - "") - "\n" - (if debug-level - (string-append "debug-level\t" - (number->string debug-level)) - "") - "\n" - (string-concatenate - (map cache->config caches))))))) - -(define* (nscd-service #:optional (config %nscd-default-configuration) - #:key (glibc (canonical-package glibc)) - (name-services '())) + (if log-file + (string-append "logfile\t" log-file) + "") + "\n" + (if debug-level + (string-append "debug-level\t" + (number->string debug-level)) + "") + "\n" + (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 #$@name-services)) + ":"))))) + (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))) + + ;; This can be extended by providing additional name services + ;; such as nss-mdns. + (compose concatenate) + (extend (lambda (config name-services) + (nscd-configuration + (inherit config) + (name-services (append + (nscd-configuration-name-services config) + name-services))))))) + +(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. Optionally, -@code{#:name-services} is a list of packages that provide name service switch - (NSS) modules needed by nscd. @xref{Name Service Switch}, for an example." - (mlet %store-monad ((nscd.conf (nscd.conf-file config))) - (return (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 #$glibc "/sbin/nscd") - "-f" #$nscd.conf "--foreground") - - #:environment-variables - (list (string-append "LD_LIBRARY_PATH=" - (string-join - (map (lambda (dir) - (string-append dir "/lib")) - (list #$@name-services)) - ":"))))) - (stop #~(make-kill-destructor)) - - (respawn? #f))))) - -(define* (syslog-service #:key config-file) - "Return a service that runs @code{syslogd}. -If configuration file name @var{config-file} is not specified, use some -reasonable default settings." +given @var{config}---an @code{<nscd-configuration>} object. @xref{Name +Service Switch}, for an example." + (service nscd-service-type 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 contents " +;; Snippet adapted from the GNU inetutils manual. +(define %default-syslog.conf + (plain-file "syslog.conf" " # Log all error messages, authentication messages of # level notice or higher and anything of level err or # higher to the console. @@ -576,20 +675,13 @@ reasonable default settings." # Log all the mail messages in one place. mail.* /var/log/maillog -") +")) - (mlet %store-monad - ((syslog.conf (text-file "syslog.conf" contents))) - (return - (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" #$(or config-file syslog.conf)))) - (stop #~(make-kill-destructor)))))) +(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 syslog-service-type config-file)) (define* (guix-build-accounts count #:key (group "guixbuild") @@ -638,63 +730,104 @@ 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 -@var{build-accounts} 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 -@option{--no-substitutes} (@pxref{Invoking guix-daemon, -@option{--no-substitutes}}). - -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))) - - (with-monad %store-monad - (return (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")) - #$@extra-options) - - ;; 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")) + #$@extra-options) + + ;; 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 +@var{config}." + (service guix-service-type config)) + + +;;; +;;; Udev. +;;; + +(define-record-type* <udev-configuration> + udev-configuration make-udev-configuration + udev-configuration? + (udev udev-configuration-udev ;<package> + (default udev)) + (rules udev-configuration-rules ;list of <package> + (default '()))) (define (udev-rules-union packages) "Return the union of the @code{lib/udev/rules.d} directories found in each @@ -719,149 +852,181 @@ item of @var{packages}." (union-build (string-append #$output "/lib/udev/rules.d") (filter-map rules-sub-directory '#$packages)))) - (gexp->derivation "udev-rules" build - #:modules '((guix build union) - (guix build utils)) - #:local-build? #t)) + (computed-file "udev-rules" build + #:modules '((guix build union) + (guix build utils)))) (define* (kvm-udev-rule) "Return a directory with a udev rule that changes the group of @file{/dev/kvm} to \"kvm\" and makes it #o660." ;; Apparently QEMU-KVM used to ship this rule, but now we have to add it by ;; ourselves. - (gexp->derivation "kvm-udev-rules" - #~(begin - (use-modules (guix build utils)) - - (define rules.d - (string-append #$output "/lib/udev/rules.d")) - - (mkdir-p rules.d) - (call-with-output-file - (string-append rules.d "/90-kvm.rules") - (lambda (port) - ;; Build users are part of the "kvm" group, so we - ;; can fearlessly make /dev/kvm 660 (see - ;; <http://bugs.gnu.org/18994>, for background.) - (display "\ + (computed-file "kvm-udev-rules" + #~(begin + (use-modules (guix build utils)) + + (define rules.d + (string-append #$output "/lib/udev/rules.d")) + + (mkdir-p rules.d) + (call-with-output-file + (string-append rules.d "/90-kvm.rules") + (lambda (port) + ;; Build users are part of the "kvm" group, so we + ;; can fearlessly make /dev/kvm 660 (see + ;; <http://bugs.gnu.org/18994>, for background.) + (display "\ KERNEL==\"kvm\", GROUP=\"kvm\", MODE=\"0660\"\n" port)))) - #:modules '((guix build utils)))) + #:modules '((guix build utils)))) + +(define udev-dmd-service + ;; Return a <dmd-service> for UDEV with RULES. + (match-lambda + (($ <udev-configuration> udev rules) + (let* ((rules (udev-rules-union (cons* udev (kvm-udev-rule) rules))) + (udev.conf (computed-file "udev.conf" + #~(call-with-output-file #$output + (lambda (port) + (format port + "udev_rules=\"~a/lib/udev/rules.d\"\n" + #$rules)))))) + (list + (dmd-service + (provision '(udev)) + + ;; Udev needs /dev to be a 'devtmpfs' mount so that new device nodes can + ;; be added: see + ;; <http://www.linuxfromscratch.org/lfs/view/development/chapter07/udev.html>. + (requirement '(root-file-system)) + + (documentation "Populate the /dev directory, dynamically.") + (start #~(lambda () + (define find + (@ (srfi srfi-1) find)) + + (define udevd + ;; Choose the right 'udevd'. + (find file-exists? + (map (lambda (suffix) + (string-append #$udev suffix)) + '("/libexec/udev/udevd" ;udev + "/sbin/udevd")))) ;eudev + + (define (wait-for-udevd) + ;; Wait until someone's listening on udevd's control + ;; socket. + (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0))) + (let try () + (catch 'system-error + (lambda () + (connect sock PF_UNIX "/run/udev/control") + (close-port sock)) + (lambda args + (format #t "waiting for udevd...~%") + (usleep 500000) + (try)))))) + + ;; Allow udev to find the modules. + (setenv "LINUX_MODULE_DIRECTORY" + "/run/booted-system/kernel/lib/modules") + + ;; The first one is for udev, the second one for eudev. + (setenv "UDEV_CONFIG_FILE" #$udev.conf) + (setenv "EUDEV_RULES_DIRECTORY" + (string-append #$rules "/lib/udev/rules.d")) + + (let ((pid (primitive-fork))) + (case pid + ((0) + (exec-command (list udevd))) + (else + ;; Wait until udevd is up and running. This + ;; appears to be needed so that the events + ;; triggered below are actually handled. + (wait-for-udevd) + + ;; Trigger device node creation. + (system* (string-append #$udev "/bin/udevadm") + "trigger" "--action=add") + + ;; Wait for things to settle down. + (system* (string-append #$udev "/bin/udevadm") + "settle") + pid))))) + (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. + (respawn? #f))))))) + +(define udev-service-type + (service-type (name 'udev) + (extensions + (list (service-extension dmd-root-service-type + udev-dmd-service))) + + (compose concatenate) ;concatenate the list of rules + (extend (lambda (config rules) + (match config + (($ <udev-configuration> udev initial-rules) + (udev-configuration + (udev udev) + (rules (append initial-rules rules))))))))) (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}." - (mlet* %store-monad ((kvm (kvm-udev-rule)) - (rules (udev-rules-union (cons* udev kvm rules))) - (udev.conf (text-file* "udev.conf" - "udev_rules=\"" rules - "/lib/udev/rules.d\"\n"))) - (return (service - (provision '(udev)) - - ;; Udev needs /dev to be a 'devtmpfs' mount so that new device - ;; nodes can be added: see - ;; <http://www.linuxfromscratch.org/lfs/view/development/chapter07/udev.html>. - (requirement '(root-file-system)) - - (documentation "Populate the /dev directory, dynamically.") - (start #~(lambda () - (define find - (@ (srfi srfi-1) find)) - - (define udevd - ;; Choose the right 'udevd'. - (find file-exists? - (map (lambda (suffix) - (string-append #$udev suffix)) - '("/libexec/udev/udevd" ;udev - "/sbin/udevd")))) ;eudev - - (define (wait-for-udevd) - ;; Wait until someone's listening on udevd's control - ;; socket. - (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0))) - (let try () - (catch 'system-error - (lambda () - (connect sock PF_UNIX "/run/udev/control") - (close-port sock)) - (lambda args - (format #t "waiting for udevd...~%") - (usleep 500000) - (try)))))) - - ;; Allow udev to find the modules. - (setenv "LINUX_MODULE_DIRECTORY" - "/run/booted-system/kernel/lib/modules") - - ;; The first one is for udev, the second one for eudev. - (setenv "UDEV_CONFIG_FILE" #$udev.conf) - (setenv "EUDEV_RULES_DIRECTORY" - (string-append #$rules "/lib/udev/rules.d")) - - (let ((pid (primitive-fork))) - (case pid - ((0) - (exec-command (list udevd))) - (else - ;; Wait until udevd is up and running. This - ;; appears to be needed so that the events - ;; triggered below are actually handled. - (wait-for-udevd) - - ;; Trigger device node creation. - (system* (string-append #$udev "/bin/udevadm") - "trigger" "--action=add") - - ;; Wait for things to settle down. - (system* (string-append #$udev "/bin/udevadm") - "settle") - pid))))) - (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. - (respawn? #f))))) + (service udev-service-type + (udev-configuration (udev udev) (rules 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." - (with-monad %store-monad - (return (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 device-mapping-service-type + (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)))) - '())) - - (with-monad %store-monad - (return (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 swap-service-type device)) (define %base-services ;; Convenience variable holding the basic services. - (let ((motd (text-file "motd" " + (let ((motd (plain-file "motd" " This is the GNU operating system, welcome!\n\n"))) (list (console-font-service "tty1") (console-font-service "tty2") @@ -870,12 +1035,19 @@ This is the GNU operating system, welcome!\n\n"))) (console-font-service "tty5") (console-font-service "tty6") - (mingetty-service "tty1" #:motd motd) - (mingetty-service "tty2" #:motd motd) - (mingetty-service "tty3" #:motd motd) - (mingetty-service "tty4" #:motd motd) - (mingetty-service "tty5" #:motd motd) - (mingetty-service "tty6" #:motd motd) + (mingetty-service (mingetty-configuration + (tty "tty1") (motd motd))) + (mingetty-service (mingetty-configuration + (tty "tty2") (motd motd))) + (mingetty-service (mingetty-configuration + (tty "tty3") (motd motd))) + (mingetty-service (mingetty-configuration + (tty "tty4") (motd motd))) + (mingetty-service (mingetty-configuration + (tty "tty5") (motd motd))) + (mingetty-service (mingetty-configuration + (tty "tty6") (motd motd))) + (static-networking-service "lo" "127.0.0.1" #:provision '(loopback)) (syslog-service) @@ -885,9 +1057,6 @@ This is the GNU operating system, welcome!\n\n"))) ;; The LVM2 rules are needed as soon as LVM2 or the device-mapper is ;; used, so enable them by default. The FUSE and ALSA rules are ;; less critical, but handy. - ;; - ;; XXX Keep this in sync with the 'udev-service' call in - ;; %desktop-services. (udev-service #:rules (list lvm2 fuse alsa-utils crda))))) ;;; base.scm ends here diff --git a/gnu/services/databases.scm b/gnu/services/databases.scm index 18f41e74da..8fdd222a3b 100644 --- a/gnu/services/databases.scm +++ b/gnu/services/databases.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 David Thompson <davet@gnu.org> +;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,13 +19,13 @@ (define-module (gnu services databases) #:use-module (gnu services) + #:use-module (gnu services dmd) #:use-module (gnu system shadow) #:use-module (gnu packages admin) #:use-module (gnu packages databases) #:use-module (guix records) - #:use-module (guix monads) - #:use-module (guix store) #:use-module (guix gexp) + #:use-module (ice-9 match) #:export (postgresql-service)) ;;; Commentary: @@ -33,24 +34,100 @@ ;;; ;;; Code: +(define-record-type* <postgresql-configuration> + postgresql-configuration make-postgresql-configuration + postgresql-configuration? + (postgresql postgresql-configuration-postgresql ;<package> + (default postgresql)) + (config-file postgresql-configuration-file) + (data-directory postgresql-configuration-data-directory)) + (define %default-postgres-hba - (text-file "pg_hba.conf" - " + (plain-file "pg_hba.conf" + " local all all trust host all all 127.0.0.1/32 trust host all all ::1/128 trust")) (define %default-postgres-ident - (text-file "pg_ident.conf" + (plain-file "pg_ident.conf" "# MAPNAME SYSTEM-USERNAME PG-USERNAME")) (define %default-postgres-config - (mlet %store-monad ((hba %default-postgres-hba) - (ident %default-postgres-ident)) - (text-file* "postgresql.conf" - ;; The daemon will not start without these. - "hba_file = '" hba "'\n" - "ident_file = '" ident "'\n"))) + (mixed-text-file "postgresql.conf" + "hba_file = '" %default-postgres-hba "'\n" + "ident_file = '" %default-postgres-ident "\n")) + +(define %postgresql-accounts + (list (user-group (name "postgres") (system? #t)) + (user-account + (name "postgres") + (group "postgres") + (system? #t) + (comment "PostgreSQL server user") + (home-directory "/var/empty") + (shell #~(string-append #$shadow "/sbin/nologin"))))) + +(define postgresql-activation + (match-lambda + (($ <postgresql-configuration> postgresql config-file data-directory) + #~(begin + (use-modules (guix build utils) + (ice-9 match)) + + (let ((user (getpwnam "postgres")) + (initdb (string-append #$postgresql "/bin/initdb"))) + ;; Create db state directory. + (mkdir-p #$data-directory) + (chown #$data-directory (passwd:uid user) (passwd:gid user)) + + ;; Drop privileges and init state directory in a new + ;; process. Wait for it to finish before proceeding. + (match (primitive-fork) + (0 + ;; Exit with a non-zero status code if an exception is thrown. + (dynamic-wind + (const #t) + (lambda () + (setgid (passwd:gid user)) + (setuid (passwd:uid user)) + (primitive-exit (system* initdb "-D" #$data-directory))) + (lambda () + (primitive-exit 1)))) + (pid (waitpid pid)))))))) + +(define postgresql-dmd-service + (match-lambda + (($ <postgresql-configuration> postgresql config-file data-directory) + (let ((start-script + ;; Wrapper script that switches to the 'postgres' user before + ;; launching daemon. + (program-file "start-postgres" + #~(let ((user (getpwnam "postgres")) + (postgres (string-append #$postgresql + "/bin/postgres"))) + (setgid (passwd:gid user)) + (setuid (passwd:uid user)) + (system* postgres + (string-append "--config-file=" + #$config-file) + "-D" #$data-directory))))) + (list (dmd-service + (provision '(postgres)) + (documentation "Run the PostgreSQL daemon.") + (requirement '(user-processes loopback)) + (start #~(make-forkexec-constructor #$start-script)) + (stop #~(make-kill-destructor)))))))) + +(define postgresql-service-type + (service-type (name 'postgresql) + (extensions + (list (service-extension dmd-root-service-type + postgresql-dmd-service) + (service-extension activation-service-type + postgresql-activation) + (service-extension account-service-type + (const %postgresql-accounts)))))) (define* (postgresql-service #:key (postgresql postgresql) (config-file %default-postgres-config) @@ -59,63 +136,8 @@ host all all ::1/128 trust")) The PostgreSQL daemon loads its runtime configuration from @var{config-file} and stores the database cluster in @var{data-directory}." - ;; Wrapper script that switches to the 'postgres' user before launching - ;; daemon. - (define start-script - (mlet %store-monad ((config-file config-file)) - (gexp->script "start-postgres" - #~(let ((user (getpwnam "postgres")) - (postgres (string-append #$postgresql - "/bin/postgres"))) - (setgid (passwd:gid user)) - (setuid (passwd:uid user)) - (system* postgres - (string-append "--config-file=" #$config-file) - "-D" #$data-directory))))) - - (define activate - #~(begin - (use-modules (guix build utils) - (ice-9 match)) - - (let ((user (getpwnam "postgres")) - (initdb (string-append #$postgresql "/bin/initdb"))) - ;; Create db state directory. - (mkdir-p #$data-directory) - (chown #$data-directory (passwd:uid user) (passwd:gid user)) - - ;; Drop privileges and init state directory in a new - ;; process. Wait for it to finish before proceeding. - (match (primitive-fork) - (0 - ;; Exit with a non-zero status code if an exception is thrown. - (dynamic-wind - (const #t) - (lambda () - (setgid (passwd:gid user)) - (setuid (passwd:uid user)) - (primitive-exit (system* initdb "-D" #$data-directory))) - (lambda () - (primitive-exit 1)))) - (pid (waitpid pid)))))) - - (mlet %store-monad ((start-script start-script)) - (return - (service - (provision '(postgres)) - (documentation "Run the PostgreSQL daemon.") - (requirement '(user-processes loopback)) - (start #~(make-forkexec-constructor #$start-script)) - (stop #~(make-kill-destructor)) - (activate activate) - (user-groups (list (user-group - (name "postgres") - (system? #t)))) - (user-accounts (list (user-account - (name "postgres") - (group "postgres") - (system? #t) - (comment "PostgreSQL server user") - (home-directory "/var/empty") - (shell - #~(string-append #$shadow "/sbin/nologin"))))))))) + (service postgresql-service-type + (postgresql-configuration + (postgresql postgresql) + (config-file config-file) + (data-directory data-directory)))) diff --git a/gnu/services/dbus.scm b/gnu/services/dbus.scm new file mode 100644 index 0000000000..e4ecd961c5 --- /dev/null +++ b/gnu/services/dbus.scm @@ -0,0 +1,178 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (gnu services dbus) + #:use-module (gnu services) + #:use-module (gnu services dmd) + #:use-module (gnu system shadow) + #:use-module (gnu packages glib) + #:use-module (gnu packages admin) + #:use-module (guix gexp) + #:use-module (guix records) + #:use-module (srfi srfi-1) + #:use-module (ice-9 match) + #:export (dbus-root-service-type + dbus-service)) + +;;; +;;; D-Bus. +;;; + +(define-record-type* <dbus-configuration> + dbus-configuration make-dbus-configuration + dbus-configuration? + (dbus dbus-configuration-dbus ;<package> + (default dbus)) + (services dbus-configuration-services ;list of <package> + (default '()))) + +(define (dbus-configuration-directory dbus services) + "Return a configuration directory for @var{dbus} that includes the +@code{etc/dbus-1/system.d} directories of each package listed in +@var{services}." + (define build + #~(begin + (use-modules (sxml simple) + (srfi srfi-1)) + + (define (services->sxml services) + ;; Return the SXML 'includedir' clauses for DIRS. + `(busconfig + ,@(append-map (lambda (dir) + `((includedir + ,(string-append dir "/etc/dbus-1/system.d")) + (servicedir ;for '.service' files + ,(string-append dir "/share/dbus-1/services")) + (servicedir ;likewise, for auto-activation + ,(string-append + dir + "/share/dbus-1/system-services")))) + services))) + + (mkdir #$output) + (copy-file (string-append #$dbus "/etc/dbus-1/system.conf") + (string-append #$output "/system.conf")) + + ;; The default 'system.conf' has an <includedir> clause for + ;; 'system.d', so create it. + (mkdir (string-append #$output "/system.d")) + + ;; 'system-local.conf' is automatically included by the default + ;; 'system.conf', so this is where we stuff our own things. + (call-with-output-file (string-append #$output "/system-local.conf") + (lambda (port) + (sxml->xml (services->sxml (list #$@services)) + port))))) + + (computed-file "dbus-configuration" build)) + +(define %dbus-accounts + ;; Accounts used by the system bus. + (list (user-group (name "messagebus") (system? #t)) + (user-account + (name "messagebus") + (group "messagebus") + (system? #t) + (comment "D-Bus system bus user") + (home-directory "/var/run/dbus") + (shell #~(string-append #$shadow "/sbin/nologin"))))) + +(define (dbus-activation config) + "Return an activation gexp for D-Bus using @var{config}." + #~(begin + (use-modules (guix build utils)) + + (mkdir-p "/var/run/dbus") + + (let ((user (getpwnam "messagebus"))) + (chown "/var/run/dbus" + (passwd:uid user) (passwd:gid user))) + + (unless (file-exists? "/etc/machine-id") + (format #t "creating /etc/machine-id...~%") + (let ((prog (string-append #$(dbus-configuration-dbus config) + "/bin/dbus-uuidgen"))) + ;; XXX: We can't use 'system' because the initrd's + ;; guile system(3) only works when 'sh' is in $PATH. + (let ((pid (primitive-fork))) + (if (zero? pid) + (call-with-output-file "/etc/machine-id" + (lambda (port) + (close-fdes 1) + (dup2 (port->fdes port) 1) + (execl prog))) + (waitpid pid))))))) + +(define dbus-dmd-service + (match-lambda + (($ <dbus-configuration> dbus services) + (let ((conf (dbus-configuration-directory dbus services))) + (list (dmd-service + (documentation "Run the D-Bus system daemon.") + (provision '(dbus-system)) + (requirement '(user-processes)) + (start #~(make-forkexec-constructor + (list (string-append #$dbus "/bin/dbus-daemon") + "--nofork" + (string-append "--config-file=" #$conf + "/system.conf")))) + (stop #~(make-kill-destructor)))))))) + +(define dbus-root-service-type + (service-type (name 'dbus) + (extensions + (list (service-extension dmd-root-service-type + dbus-dmd-service) + (service-extension activation-service-type + dbus-activation) + (service-extension account-service-type + (const %dbus-accounts)))) + + ;; Extensions consist of lists of packages (representing D-Bus + ;; services) that we just concatenate. + ;; + ;; FIXME: We need 'dbus-daemon-launch-helper' to be + ;; setuid-root for auto-activation to work. + (compose concatenate) + + ;; The service's parameters field is extended by augmenting + ;; its <dbus-configuration> 'services' field. + (extend (lambda (config services) + (dbus-configuration + (inherit config) + (services + (append (dbus-configuration-services config) + services))))))) + +(define* (dbus-service #:key (dbus dbus) (services '())) + "Return a service that runs the \"system bus\", using @var{dbus}, with +support for @var{services}. + +@uref{http://dbus.freedesktop.org/, D-Bus} is an inter-process communication +facility. Its system bus is used to allow system services to communicate and +be notified of system-wide events. + +@var{services} must be a list of packages that provide an +@file{etc/dbus-1/system.d} directory containing additional D-Bus configuration +and policy files. For example, to allow avahi-daemon to use the system bus, +@var{services} must be equal to @code{(list avahi)}." + (service dbus-root-service-type + (dbus-configuration (dbus dbus) + (services services)))) + +;;; dbus.scm ends here diff --git a/gnu/services/desktop.scm b/gnu/services/desktop.scm index b91bdd8ad3..69edc6d9bb 100644 --- a/gnu/services/desktop.scm +++ b/gnu/services/desktop.scm @@ -20,7 +20,9 @@ (define-module (gnu services desktop) #:use-module (gnu services) + #:use-module (gnu services dmd) #:use-module (gnu services base) + #:use-module (gnu services dbus) #:use-module (gnu services avahi) #:use-module (gnu services xorg) #:use-module (gnu services networking) @@ -31,17 +33,14 @@ #:use-module (gnu packages freedesktop) #:use-module (gnu packages gnome) #:use-module (gnu packages avahi) - #:use-module (gnu packages wicd) #:use-module (gnu packages polkit) - #:use-module ((gnu packages linux) - #:select (lvm2 fuse alsa-utils crda)) - #:use-module (guix monads) #:use-module (guix records) + #:use-module (guix packages) #:use-module (guix store) #:use-module (guix gexp) + #:use-module (srfi srfi-1) #:use-module (ice-9 match) - #:export (dbus-service - upower-service + #:export (upower-service colord-service geoclue-application %standard-geoclue-applications @@ -65,134 +64,133 @@ (define (bool value) (if value "true\n" "false\n")) - -;;; -;;; D-Bus. -;;; -(define (dbus-configuration-directory dbus services) - "Return a configuration directory for @var{dbus} that includes the -@code{etc/dbus-1/system.d} directories of each package listed in -@var{services}." - (define build - #~(begin - (use-modules (sxml simple) - (srfi srfi-1)) - - (define (services->sxml services) - ;; Return the SXML 'includedir' clauses for DIRS. - `(busconfig - ,@(append-map (lambda (dir) - `((includedir - ,(string-append dir "/etc/dbus-1/system.d")) - (servicedir ;for '.service' files - ,(string-append dir "/share/dbus-1/services")))) - services))) - - (mkdir #$output) - (copy-file (string-append #$dbus "/etc/dbus-1/system.conf") - (string-append #$output "/system.conf")) - - ;; The default 'system.conf' has an <includedir> clause for - ;; 'system.d', so create it. - (mkdir (string-append #$output "/system.d")) - - ;; 'system-local.conf' is automatically included by the default - ;; 'system.conf', so this is where we stuff our own things. - (call-with-output-file (string-append #$output "/system-local.conf") - (lambda (port) - (sxml->xml (services->sxml (list #$@services)) - port))))) - - (gexp->derivation "dbus-configuration" build)) - -(define* (dbus-service services #:key (dbus dbus)) - "Return a service that runs the \"system bus\", using @var{dbus}, with -support for @var{services}. - -@uref{http://dbus.freedesktop.org/, D-Bus} is an inter-process communication -facility. Its system bus is used to allow system services to communicate and -be notified of system-wide events. - -@var{services} must be a list of packages that provide an -@file{etc/dbus-1/system.d} directory containing additional D-Bus configuration -and policy files. For example, to allow avahi-daemon to use the system bus, -@var{services} must be equal to @code{(list avahi)}." - (mlet %store-monad ((conf (dbus-configuration-directory dbus services))) - (return - (service - (documentation "Run the D-Bus system daemon.") - (provision '(dbus-system)) - (requirement '(user-processes)) - (start #~(make-forkexec-constructor - (list (string-append #$dbus "/bin/dbus-daemon") - "--nofork" - (string-append "--config-file=" #$conf "/system.conf")))) - (stop #~(make-kill-destructor)) - (user-groups (list (user-group - (name "messagebus") - (system? #t)))) - (user-accounts (list (user-account - (name "messagebus") - (group "messagebus") - (system? #t) - (comment "D-Bus system bus user") - (home-directory "/var/run/dbus") - (shell - #~(string-append #$shadow "/sbin/nologin"))))) - (activate #~(begin - (use-modules (guix build utils)) - - (mkdir-p "/var/run/dbus") - - (let ((user (getpwnam "messagebus"))) - (chown "/var/run/dbus" - (passwd:uid user) (passwd:gid user))) - - (unless (file-exists? "/etc/machine-id") - (format #t "creating /etc/machine-id...~%") - (let ((prog (string-append #$dbus "/bin/dbus-uuidgen"))) - ;; XXX: We can't use 'system' because the initrd's - ;; guile system(3) only works when 'sh' is in $PATH. - (let ((pid (primitive-fork))) - (if (zero? pid) - (call-with-output-file "/etc/machine-id" - (lambda (port) - (close-fdes 1) - (dup2 (port->fdes port) 1) - (execl prog))) - (waitpid pid))))))))))) +(define (wrapped-dbus-service service program variable value) + "Return a wrapper for @var{service}, a package containing a D-Bus service, +where @var{program} is wrapped such that environment variable @var{variable} +is set to @var{value} when the bus daemon launches it." + (define wrapper + (program-file (string-append (package-name service) "-program-wrapper") + #~(begin + (setenv #$variable #$value) + (apply execl (string-append #$service "/" #$program) + (string-append #$service "/" #$program) + (cdr (command-line)))))) + + (computed-file (string-append (package-name service) "-wrapper") + #~(begin + (use-modules (guix build utils)) + + (define service-directory + "/share/dbus-1/system-services") + + (mkdir-p (dirname (string-append #$output + service-directory))) + (copy-recursively (string-append #$service + service-directory) + (string-append #$output + service-directory)) + (symlink (string-append #$service "/etc") ;for etc/dbus-1 + (string-append #$output "/etc")) + + (for-each (lambda (file) + (substitute* file + (("Exec[[:blank:]]*=[[:blank:]]*([[:graph:]]+)(.*)$" + _ original-program arguments) + (string-append "Exec=" #$wrapper arguments + "\n")))) + (find-files #$output "\\.service$"))) + #:modules '((guix build utils)))) ;;; ;;; Upower D-Bus service. ;;; -(define* (upower-configuration-file #:key watts-up-pro? poll-batteries? - ignore-lid? use-percentage-for-policy? - percentage-low percentage-critical - percentage-action time-low - time-critical time-action - critical-power-action) - "Return an upower-daemon configuration file." - (text-file "UPower.conf" - (string-append - "[UPower]\n" - "EnableWattsUpPro=" (bool watts-up-pro?) - "NoPollBatteries=" (bool (not poll-batteries?)) - "IgnoreLid=" (bool ignore-lid?) - "UsePercentageForPolicy=" (bool use-percentage-for-policy?) - "PercentageLow=" (number->string percentage-low) "\n" - "PercentageCritical=" (number->string percentage-critical) "\n" - "PercentageAction=" (number->string percentage-action) "\n" - "TimeLow=" (number->string time-low) "\n" - "TimeCritical=" (number->string time-critical) "\n" - "TimeAction=" (number->string time-action) "\n" - "CriticalPowerAction=" (match critical-power-action - ('hybrid-sleep "HybridSleep") - ('hibernate "Hibernate") - ('power-off "PowerOff")) - "\n"))) +;; TODO: Export. +(define-record-type* <upower-configuration> + upower-configuration make-upower-configuration + upower-configuration? + (upower upower-configuration-upower + (default upower)) + (watts-up-pro? upower-configuration-watts-up-pro?) + (poll-batteries? upower-configuration-poll-batteries?) + (ignore-lid? upower-configuration-ignore-lid?) + (use-percentage-for-policy? upower-configuration-use-percentage-for-policy?) + (percentage-low upower-configuration-percentage-low) + (percentage-critical upower-configuration-percentage-critical) + (percentage-action upower-configuration-percentage-action) + (time-low upower-configuration-time-low) + (time-critical upower-configuration-time-critical) + (time-action upower-configuration-time-action) + (critical-power-action upower-configuration-critical-power-action)) + +(define* upower-configuration-file + ;; Return an upower-daemon configuration file. + (match-lambda + (($ <upower-configuration> upower + watts-up-pro? poll-batteries? ignore-lid? use-percentage-for-policy? + percentage-low percentage-critical percentage-action time-low + time-critical time-action critical-power-action) + (plain-file "UPower.conf" + (string-append + "[UPower]\n" + "EnableWattsUpPro=" (bool watts-up-pro?) + "NoPollBatteries=" (bool (not poll-batteries?)) + "IgnoreLid=" (bool ignore-lid?) + "UsePercentageForPolicy=" (bool use-percentage-for-policy?) + "PercentageLow=" (number->string percentage-low) "\n" + "PercentageCritical=" (number->string percentage-critical) "\n" + "PercentageAction=" (number->string percentage-action) "\n" + "TimeLow=" (number->string time-low) "\n" + "TimeCritical=" (number->string time-critical) "\n" + "TimeAction=" (number->string time-action) "\n" + "CriticalPowerAction=" (match critical-power-action + ('hybrid-sleep "HybridSleep") + ('hibernate "Hibernate") + ('power-off "PowerOff")) + "\n"))))) + +(define %upower-activation + #~(begin + (use-modules (guix build utils)) + (mkdir-p "/var/lib/upower"))) + +(define (upower-dbus-service config) + (list (wrapped-dbus-service (upower-configuration-upower config) + "libexec/upowerd" + "UPOWER_CONF_FILE_NAME" + (upower-configuration-file config)))) + +(define (upower-dmd-service config) + "Return a dmd service for UPower with CONFIG." + (let ((upower (upower-configuration-upower config)) + (config (upower-configuration-file config))) + (list (dmd-service + (documentation "Run the UPower power and battery monitor.") + (provision '(upower-daemon)) + (requirement '(dbus-system udev)) + + (start #~(make-forkexec-constructor + (list (string-append #$upower "/libexec/upowerd")) + #:environment-variables + (list (string-append "UPOWER_CONF_FILE_NAME=" + #$config)))) + (stop #~(make-kill-destructor)))))) + +(define upower-service-type + (service-type (name 'upower) + (extensions + (list (service-extension dbus-root-service-type + upower-dbus-service) + (service-extension dmd-root-service-type + upower-dmd-service) + (service-extension activation-service-type + (const %upower-activation)) + (service-extension udev-service-type + (compose + list + upower-configuration-upower)))))) (define* (upower-service #:key (upower upower) (watts-up-pro? #f) @@ -210,93 +208,97 @@ and policy files. For example, to allow avahi-daemon to use the system bus, @command{upowerd}}, a system-wide monitor for power consumption and battery levels, with the given configuration settings. It implements the @code{org.freedesktop.UPower} D-Bus interface, and is notably used by GNOME." - (mlet %store-monad ((config (upower-configuration-file - #:watts-up-pro? watts-up-pro? - #:poll-batteries? poll-batteries? - #:ignore-lid? ignore-lid? - #:use-percentage-for-policy? use-percentage-for-policy? - #:percentage-low percentage-low - #:percentage-critical percentage-critical - #:percentage-action percentage-action - #:time-low time-low - #:time-critical time-critical - #:time-action time-action - #:critical-power-action critical-power-action))) - (return - (service - (documentation "Run the UPower power and battery monitor.") - (provision '(upower-daemon)) - (requirement '(dbus-system udev)) - - (start #~(make-forkexec-constructor - (list (string-append #$upower "/libexec/upowerd")) - #:environment-variables - (list (string-append "UPOWER_CONF_FILE_NAME=" #$config)))) - (stop #~(make-kill-destructor)) - (activate #~(begin - (use-modules (guix build utils)) - (mkdir-p "/var/lib/upower") - (let ((user (getpwnam "upower"))) - (chown "/var/lib/upower" - (passwd:uid user) (passwd:gid user))))) - - (user-groups (list (user-group - (name "upower") - (system? #t)))) - (user-accounts (list (user-account - (name "upower") - (group "upower") - (system? #t) - (comment "UPower daemon user") - (home-directory "/var/empty") - (shell - #~(string-append #$shadow "/sbin/nologin"))))))))) + (let ((config (upower-configuration + (watts-up-pro? watts-up-pro?) + (poll-batteries? poll-batteries?) + (ignore-lid? ignore-lid?) + (use-percentage-for-policy? use-percentage-for-policy?) + (percentage-low percentage-low) + (percentage-critical percentage-critical) + (percentage-action percentage-action) + (time-low time-low) + (time-critical time-critical) + (time-action time-action) + (critical-power-action critical-power-action)))) + (service upower-service-type config))) ;;; ;;; Colord D-Bus service. ;;; +(define %colord-activation + #~(begin + (use-modules (guix build utils)) + (mkdir-p "/var/lib/colord") + (let ((user (getpwnam "colord"))) + (chown "/var/lib/colord" + (passwd:uid user) (passwd:gid user))))) + +(define %colord-accounts + (list (user-group (name "colord") (system? #t)) + (user-account + (name "colord") + (group "colord") + (system? #t) + (comment "colord daemon user") + (home-directory "/var/empty") + (shell #~(string-append #$shadow "/sbin/nologin"))))) + +(define (colord-dmd-service colord) + "Return a dmd service for COLORD." + ;; TODO: Remove when D-Bus activation works. + (list (dmd-service + (documentation "Run the colord color management service.") + (provision '(colord-daemon)) + (requirement '(dbus-system udev)) + (start #~(make-forkexec-constructor + (list (string-append #$colord "/libexec/colord")))) + (stop #~(make-kill-destructor))))) + +(define colord-service-type + (service-type (name 'colord) + (extensions + (list (service-extension account-service-type + (const %colord-accounts)) + (service-extension activation-service-type + (const %colord-activation)) + (service-extension dmd-root-service-type + colord-dmd-service) + + ;; Colord is a D-Bus service that dbus-daemon can + ;; activate. + (service-extension dbus-root-service-type list) + + ;; Colord provides "color device" rules for udev. + (service-extension udev-service-type list))))) + (define* (colord-service #:key (colord colord)) "Return a service that runs @command{colord}, a system service with a D-Bus interface to manage the color profiles of input and output devices such as screens and scanners. It is notably used by the GNOME Color Manager graphical tool. See @uref{http://www.freedesktop.org/software/colord/, the colord web site} for more information." - (with-monad %store-monad - (return - (service - (documentation "Run the colord color management service.") - (provision '(colord-daemon)) - (requirement '(dbus-system udev)) - - (start #~(make-forkexec-constructor - (list (string-append #$colord "/libexec/colord")))) - (stop #~(make-kill-destructor)) - (activate #~(begin - (use-modules (guix build utils)) - (mkdir-p "/var/lib/colord") - (let ((user (getpwnam "colord"))) - (chown "/var/lib/colord" - (passwd:uid user) (passwd:gid user))))) - - (user-groups (list (user-group - (name "colord") - (system? #t)))) - (user-accounts (list (user-account - (name "colord") - (group "colord") - (system? #t) - (comment "colord daemon user") - (home-directory "/var/empty") - (shell - #~(string-append #$shadow "/sbin/nologin"))))))))) + (service colord-service-type colord)) ;;; ;;; GeoClue D-Bus service. ;;; +;; TODO: Export. +(define-record-type* <geoclue-configuration> + geoclue-configuration make-geoclue-configuration + geoclue-configuration? + (geoclue geoclue-configuration-geoclue + (default geoclue)) + (whitelist geoclue-configuration-whitelist) + (wifi-geolocation-url geoclue-configuration-wifi-geolocation-url) + (submit-data? geoclue-configuration-submit-data?) + (wifi-submission-url geoclue-configuration-wifi-submission-url) + (submission-nick geoclue-configuration-submission-nick) + (applications geoclue-configuration-applications)) + (define* (geoclue-application name #:key (allowed? #t) system? (users '())) "Configure default GeoClue access permissions for an application. NAME is the Desktop ID of the application, without the .desktop part. If ALLOWED? is @@ -316,21 +318,67 @@ users are allowed." (geoclue-application "epiphany" #:system? #f) (geoclue-application "firefox" #:system? #f))) -(define* (geoclue-configuration-file #:key whitelist wifi-geolocation-url - submit-data? - wifi-submission-url submission-nick - applications) +(define* (geoclue-configuration-file config) "Return a geoclue configuration file." - (text-file "geoclue.conf" - (string-append - "[agent]\n" - "whitelist=" (string-join whitelist ";") "\n" - "[wifi]\n" - "url=" wifi-geolocation-url "\n" - "submit-data=" (bool submit-data?) - "submission-url=" wifi-submission-url "\n" - "submission-nick=" submission-nick "\n" - (string-join applications "\n")))) + (plain-file "geoclue.conf" + (string-append + "[agent]\n" + "whitelist=" + (string-join (geoclue-configuration-whitelist config) + ";") "\n" + "[wifi]\n" + "url=" (geoclue-configuration-wifi-geolocation-url config) "\n" + "submit-data=" (bool (geoclue-configuration-submit-data? config)) + "submission-url=" + (geoclue-configuration-wifi-submission-url config) "\n" + "submission-nick=" + (geoclue-configuration-submission-nick config) + "\n" + (string-join (geoclue-configuration-applications config) + "\n")))) + +(define (geoclue-dbus-service config) + (list (wrapped-dbus-service (geoclue-configuration-geoclue config) + "libexec/geoclue" + "GEOCLUE_CONFIG_FILE" + (geoclue-configuration-file config)))) + +(define (geoclue-dmd-service config) + "Return a GeoClue dmd service for CONFIG." + ;; TODO: Remove when D-Bus activation works. + (let ((geoclue (geoclue-configuration-geoclue config)) + (config (geoclue-configuration-file config))) + (list (dmd-service + (documentation "Run the GeoClue location service.") + (provision '(geoclue-daemon)) + (requirement '(dbus-system)) + + (start #~(make-forkexec-constructor + (list (string-append #$geoclue "/libexec/geoclue")) + #:user "geoclue" + #:environment-variables + (list (string-append "GEOCLUE_CONFIG_FILE=" #$config)))) + (stop #~(make-kill-destructor)))))) + +(define %geoclue-accounts + (list (user-group (name "geoclue") (system? #t)) + (user-account + (name "geoclue") + (group "geoclue") + (system? #t) + (comment "GeoClue daemon user") + (home-directory "/var/empty") + (shell "/run/current-system/profile/sbin/nologin")))) + +(define geoclue-service-type + (service-type (name 'geoclue) + (extensions + (list (service-extension dbus-root-service-type + geoclue-dbus-service) + (service-extension dmd-root-service-type + geoclue-dmd-service) + (service-extension account-service-type + (const %geoclue-accounts)))))) (define* (geoclue-service #:key (geoclue geoclue) (whitelist '()) @@ -350,73 +398,67 @@ and Epiphany web browsers are able to ask for the user's location, and in the case of Icecat and Epiphany, both will ask the user for permission first. See @uref{https://wiki.freedesktop.org/www/Software/GeoClue/, the geoclue web site} for more information." - (mlet %store-monad ((config (geoclue-configuration-file - #:whitelist whitelist - #:wifi-geolocation-url wifi-geolocation-url - #:submit-data? submit-data? - #:wifi-submission-url wifi-submission-url - #:submission-nick submission-nick - #:applications applications))) - (return - (service - (documentation "Run the GeoClue location service.") - (provision '(geoclue-daemon)) - (requirement '(dbus-system)) - - (start #~(make-forkexec-constructor - (list (string-append #$geoclue "/libexec/geoclue")) - #:user "geoclue" - #:environment-variables - (list (string-append "GEOCLUE_CONFIG_FILE=" #$config)))) - (stop #~(make-kill-destructor)) - - (user-groups (list (user-group - (name "geoclue") - (system? #t)))) - (user-accounts (list (user-account - (name "geoclue") - (group "geoclue") - (system? #t) - (comment "GeoClue daemon user") - (home-directory "/var/empty") - (shell - "/run/current-system/profile/sbin/nologin")))))))) + (service geoclue-service-type + (geoclue-configuration + (geoclue geoclue) + (whitelist whitelist) + (wifi-geolocation-url wifi-geolocation-url) + (submit-data? submit-data?) + (wifi-submission-url wifi-submission-url) + (submission-nick submission-nick) + (applications applications)))) ;;; ;;; Polkit privilege management service. ;;; +(define %polkit-accounts + (list (user-group (name "polkitd") (system? #t)) + (user-account + (name "polkitd") + (group "polkitd") + (system? #t) + (comment "Polkit daemon user") + (home-directory "/var/empty") + (shell "/run/current-system/profile/sbin/nologin")))) + +(define %polkit-pam-services + (list (unix-pam-service "polkitd"))) + +(define (polkit-dmd-service polkit) + "Return the <dmd-service> for POLKIT." + ;; TODO: Remove when D-Bus activation works. + (list (dmd-service + (documentation "Run the polkit privilege management service.") + (provision '(polkit-daemon)) + (requirement '(dbus-system)) + + (start #~(make-forkexec-constructor + (list (string-append #$polkit "/lib/polkit-1/polkitd")))) + (stop #~(make-kill-destructor))))) + +(define polkit-service-type + ;; TODO: Make it extensible so it can collect policy files from other + ;; services. + (service-type (name 'polkit) + (extensions + (list (service-extension account-service-type + (const %polkit-accounts)) + (service-extension pam-root-service-type + (const %polkit-pam-services)) + (service-extension dbus-root-service-type + list) + (service-extension dmd-root-service-type + polkit-dmd-service))))) + (define* (polkit-service #:key (polkit polkit)) "Return a service that runs the @command{polkit} privilege management service. By querying the @command{polkit} service, a privileged system component can know when it should grant additional capabilities to ordinary users. For example, an ordinary user can be granted the capability to suspend the system if the user is logged in locally." - (with-monad %store-monad - (return - (service - (documentation "Run the polkit privilege management service.") - (provision '(polkit-daemon)) - (requirement '(dbus-system)) - - (start #~(make-forkexec-constructor - (list (string-append #$polkit "/lib/polkit-1/polkitd")))) - (stop #~(make-kill-destructor)) - - (user-groups (list (user-group - (name "polkitd") - (system? #t)))) - (user-accounts (list (user-account - (name "polkitd") - (group "polkitd") - (system? #t) - (comment "Polkit daemon user") - (home-directory "/var/empty") - (shell - "/run/current-system/profile/sbin/nologin")))) - - (pam-services (list (unix-pam-service "polkit-1"))))))) + (service polkit-service-type polkit)) ;;; @@ -426,6 +468,8 @@ the system if the user is logged in locally." (define-record-type* <elogind-configuration> elogind-configuration make-elogind-configuration elogind-configuration + (elogind elogind-package + (default elogind)) (kill-user-processes? elogind-kill-user-processes? (default #f)) (kill-only-users elogind-kill-only-users @@ -520,7 +564,7 @@ the system if the user is logged in locally." ((_ config str) (string-append str "\n")))) (define-syntax-rule (ini-file config file clause ...) - (text-file file (string-append (ini-file-clause config clause) ...))) + (plain-file file (string-append (ini-file-clause config clause) ...))) (ini-file config "logind.conf" "[Login]" @@ -555,69 +599,62 @@ the system if the user is logged in locally." ("HybridSleepState" (sleep-list elogind-hybrid-sleep-state)) ("HybridSleepMode" (sleep-list elogind-hybrid-sleep-mode)))) -(define* (elogind-service #:key (elogind elogind) - (config (elogind-configuration))) +(define (elogind-dmd-service config) + "Return a dmd service for elogind, using @var{config}." + (let ((config-file (elogind-configuration-file config)) + (elogind (elogind-package config))) + (list (dmd-service + (documentation "Run the elogind login and seat management service.") + (provision '(elogind)) + (requirement '(dbus-system)) + + (start #~(make-forkexec-constructor + (list (string-append #$elogind "/libexec/elogind/elogind")) + #:environment-variables + (list (string-append "ELOGIND_CONF_FILE=" #$config-file)))) + (stop #~(make-kill-destructor)))))) + +(define elogind-service-type + (service-type (name 'elogind) + (extensions + (list (service-extension dmd-root-service-type + elogind-dmd-service) + (service-extension dbus-root-service-type + (compose list elogind-package)) + (service-extension udev-service-type + (compose list elogind-package)) + ;; TODO: Extend polkit(?) and PAM. + )))) + +(define* (elogind-service #:key (config (elogind-configuration))) "Return a service that runs the @command{elogind} login and seat management service. The @command{elogind} service integrates with PAM to allow other system components to know the set of logged-in users as well as their session types (graphical, console, remote, etc.). It can also clean up after users when they log out." - (mlet %store-monad ((config-file (elogind-configuration-file config))) - (return - (service - (documentation "Run the elogind login and seat management service.") - (provision '(elogind)) - (requirement '(dbus-system)) - - (start #~(make-forkexec-constructor - (list (string-append #$elogind "/libexec/elogind/elogind")) - #:environment-variables - (list (string-append "ELOGIND_CONF_FILE=" #$config-file)))) - (stop #~(make-kill-destructor)))))) + (service elogind-service-type config)) ;;; ;;; The default set of desktop services. ;;; + (define %desktop-services ;; List of services typically useful for a "desktop" use case. (cons* (slim-service) + ;; The D-Bus clique. (avahi-service) (wicd-service) (upower-service) - ;; FIXME: The colord, geoclue, and polkit services could all be - ;; bus-activated by default, so they don't run at program startup. - ;; However, user creation and /var/lib/colord creation happen at - ;; service activation time, so we currently add them to the set of - ;; default services. (colord-service) (geoclue-service) (polkit-service) (elogind-service) - (dbus-service (list avahi wicd upower colord geoclue polkit elogind)) + (dbus-service) (ntp-service) - (map (lambda (mservice) - (mlet %store-monad ((service mservice)) - (cond - ;; Provide an nscd ready to use nss-mdns. - ((memq 'nscd (service-provision service)) - (nscd-service (nscd-configuration) - #:name-services (list nss-mdns))) - - ;; Add more rules to udev-service. - ;; - ;; XXX Keep this in sync with the 'udev-service' call in - ;; %base-services. Here we intend only to add 'upower', - ;; 'colord', and 'elogind'. - ((memq 'udev (service-provision service)) - (udev-service #:rules - (list lvm2 fuse alsa-utils crda - upower colord elogind))) - - (else mservice)))) - %base-services))) + %base-services)) ;;; desktop.scm ends here diff --git a/gnu/services/dmd.scm b/gnu/services/dmd.scm index 618df91c5e..6020ffc8eb 100644 --- a/gnu/services/dmd.scm +++ b/gnu/services/dmd.scm @@ -22,13 +22,27 @@ #: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? + dmd-service-documentation + dmd-service-provision + dmd-service-requirement + dmd-service-respawn? + dmd-service-start + dmd-service-stop + dmd-service-auto-start?)) ;;; Commentary: ;;; @@ -36,6 +50,68 @@ ;;; ;;; 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. + (compose concatenate) + (extend append) + (extensions (list (service-extension boot-service-type dmd-boot-gexp))))) + +(define %dmd-root-service + ;; The root dmd service, aka. PID 1. Its parameter is a list of + ;; <dmd-service> objects. + (service dmd-root-service-type '())) + +(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/services/lirc.scm b/gnu/services/lirc.scm index 857f362db7..6ae622579d 100644 --- a/gnu/services/lirc.scm +++ b/gnu/services/lirc.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 Alex Kost <alezost@gmail.com> +;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,18 +19,65 @@ (define-module (gnu services lirc) #:use-module (gnu services) + #:use-module (gnu services dmd) #:use-module (gnu packages lirc) - #:use-module (guix monads) - #:use-module (guix store) #:use-module (guix gexp) + #:use-module (guix records) + #:use-module (ice-9 match) #:export (lirc-service)) ;;; Commentary: ;;; -;;; LIRC services. +;;; LIRC service. ;;; ;;; Code: +(define-record-type* <lirc-configuration> + lirc-configuration make-lirc-configuration + lirc-configuation? + (lirc lirc-configuration-lirc ;<package> + (default lirc)) + (device lirc-configuration-device) ;string + (driver lirc-configuration-driver) ;string + (config-file lirc-configuration-file) ;string | file-like object + (extra-options lirc-configuration-options ;list of strings + (default '()))) + +(define %lirc-activation + #~(begin + (use-modules (guix build utils)) + (mkdir-p "/var/run/lirc"))) + +(define lirc-dmd-service + (match-lambda + (($ <lirc-configuration> lirc device driver config-file options) + (list (dmd-service + (provision '(lircd)) + (documentation "Run the LIRC daemon.") + (requirement '(user-processes)) + (start #~(make-forkexec-constructor + (list (string-append #$lirc "/sbin/lircd") + "--nodaemon" + #$@(if device + #~("--device" #$device) + #~()) + #$@(if driver + #~("--driver" #$driver) + #~()) + #$@(if config-file + #~(#$config-file) + #~()) + #$@options))) + (stop #~(make-kill-destructor))))))) + +(define lirc-service-type + (service-type (name 'lirc) + (extensions + (list (service-extension dmd-root-service-type + lirc-dmd-service) + (service-extension activation-service-type + (const %lirc-activation)))))) + (define* (lirc-service #:key (lirc lirc) device driver config-file (extra-options '())) @@ -41,28 +89,11 @@ The daemon will use specified @var{device}, @var{driver} and Finally, @var{extra-options} is a list of additional command-line options passed to @command{lircd}." - (with-monad %store-monad - (return - (service - (provision '(lircd)) - (documentation "Run the LIRC daemon.") - (requirement '(user-processes)) - (start #~(make-forkexec-constructor - (list (string-append #$lirc "/sbin/lircd") - "--nodaemon" - #$@(if device - #~("--device" #$device) - #~()) - #$@(if driver - #~("--driver" #$driver) - #~()) - #$@(if config-file - #~(#$config-file) - #~()) - #$@extra-options))) - (stop #~(make-kill-destructor)) - (activate #~(begin - (use-modules (guix build utils)) - (mkdir-p "/var/run/lirc"))))))) + (service lirc-service-type + (lirc-configuration + (lirc lirc) + (device device) (driver driver) + (config-file config-file) + (extra-options extra-options)))) ;;; lirc.scm ends here diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm index c2b404503e..52a843b54b 100644 --- a/gnu/services/networking.scm +++ b/gnu/services/networking.scm @@ -19,7 +19,10 @@ (define-module (gnu services networking) #:use-module (gnu services) + #:use-module (gnu services dmd) + #:use-module (gnu services dbus) #:use-module (gnu system shadow) + #:use-module (gnu system linux) ;PAM #:use-module (gnu packages admin) #:use-module (gnu packages linux) #:use-module (gnu packages tor) @@ -27,9 +30,9 @@ #:use-module (gnu packages ntp) #:use-module (gnu packages wicd) #:use-module (guix gexp) - #:use-module (guix store) - #:use-module (guix monads) + #:use-module (guix records) #:use-module (srfi srfi-26) + #:use-module (ice-9 match) #:export (%facebook-host-aliases static-networking-service dhcp-client-service @@ -79,6 +82,72 @@ fe80::1%lo0 www.connect.facebook.net fe80::1%lo0 apps.facebook.com\n") +(define-record-type* <static-networking> + static-networking make-static-networking + static-networking? + (interface static-networking-interface) + (ip static-networking-ip) + (gateway static-networking-gateway) + (provision static-networking-provision) + (name-servers static-networking-name-servers) + (net-tools static-networking-net-tools)) + +(define static-networking-service-type + (dmd-service-type + (match-lambda + (($ <static-networking> interface ip gateway provision + name-servers net-tools) + (let ((loopback? (memq 'loopback provision))) + + ;; TODO: Eventually replace 'route' with bindings for the appropriate + ;; ioctls. + (dmd-service + + ;; Unless we're providing the loopback interface, wait for udev to be up + ;; and running so that INTERFACE is actually usable. + (requirement (if loopback? '() '(udev))) + + (documentation + "Bring up the networking interface using a static IP address.") + (provision provision) + (start #~(lambda _ + ;; Return #t if successfully started. + (let* ((addr (inet-pton AF_INET #$ip)) + (sockaddr (make-socket-address AF_INET addr 0))) + (configure-network-interface #$interface sockaddr + (logior IFF_UP + #$(if loopback? + #~IFF_LOOPBACK + 0)))) + #$(if gateway + #~(zero? (system* (string-append #$net-tools + "/sbin/route") + "add" "-net" "default" + "gw" #$gateway)) + #t) + #$(if (pair? name-servers) + #~(call-with-output-file "/etc/resolv.conf" + (lambda (port) + (display + "# Generated by 'static-networking-service'.\n" + port) + (for-each (lambda (server) + (format port "nameserver ~a~%" + server)) + '#$name-servers))) + #t))) + (stop #~(lambda _ + ;; Return #f is successfully stopped. + (let ((sock (socket AF_INET SOCK_STREAM 0))) + (set-network-interface-flags sock #$interface 0) + (close-port sock)) + (not #$(if gateway + #~(system* (string-append #$net-tools + "/sbin/route") + "del" "-net" "default") + #t)))) + (respawn? #f))))))) + (define* (static-networking-service interface ip #:key gateway @@ -88,116 +157,70 @@ fe80::1%lo0 apps.facebook.com\n") "Return a service that starts @var{interface} with address @var{ip}. If @var{gateway} is true, it must be a string specifying the default network gateway." - (define loopback? - (memq 'loopback provision)) - - ;; TODO: Eventually replace 'route' with bindings for the appropriate - ;; ioctls. - (with-monad %store-monad - (return - (service - - ;; Unless we're providing the loopback interface, wait for udev to be up - ;; and running so that INTERFACE is actually usable. - (requirement (if loopback? '() '(udev))) - - (documentation - "Bring up the networking interface using a static IP address.") - (provision provision) + (service static-networking-service-type + (static-networking (interface interface) (ip ip) + (gateway gateway) + (provision provision) + (name-servers name-servers) + (net-tools net-tools)))) + +(define dhcp-client-service-type + (dmd-service-type + (lambda (dhcp) + (define dhclient + #~(string-append #$dhcp "/sbin/dhclient")) + + (define pid-file + "/var/run/dhclient.pid") + + (dmd-service + (documentation "Set up networking via DHCP.") + (requirement '(user-processes udev)) + + ;; XXX: Running with '-nw' ("no wait") avoids blocking for a minute when + ;; networking is unavailable, but also means that the interface is not up + ;; yet when 'start' completes. To wait for the interface to be ready, one + ;; should instead monitor udev events. + (provision '(networking)) + (start #~(lambda _ - ;; Return #t if successfully started. - (let* ((addr (inet-pton AF_INET #$ip)) - (sockaddr (make-socket-address AF_INET addr 0))) - (configure-network-interface #$interface sockaddr - (logior IFF_UP - #$(if loopback? - #~IFF_LOOPBACK - 0)))) - #$(if gateway - #~(zero? (system* (string-append #$net-tools - "/sbin/route") - "add" "-net" "default" - "gw" #$gateway)) - #t) - #$(if (pair? name-servers) - #~(call-with-output-file "/etc/resolv.conf" - (lambda (port) - (display - "# Generated by 'static-networking-service'.\n" - port) - (for-each (lambda (server) - (format port "nameserver ~a~%" - server)) - '#$name-servers))) - #t))) - (stop #~(lambda _ - ;; Return #f is successfully stopped. - (let ((sock (socket AF_INET SOCK_STREAM 0))) - (set-network-interface-flags sock #$interface 0) - (close-port sock)) - (not #$(if gateway - #~(system* (string-append #$net-tools - "/sbin/route") - "del" "-net" "default") - #t)))) - (respawn? #f))))) + ;; When invoked without any arguments, 'dhclient' discovers all + ;; non-loopback interfaces *that are up*. However, the relevant + ;; interfaces are typically down at this point. Thus we perform + ;; our own interface discovery here. + (define valid? + (negate loopback-network-interface?)) + (define ifaces + (filter valid? (all-network-interface-names))) + + ;; XXX: Make sure the interfaces are up so that 'dhclient' can + ;; actually send/receive over them. + (for-each set-network-interface-up ifaces) + + (false-if-exception (delete-file #$pid-file)) + (let ((pid (fork+exec-command + (cons* #$dhclient "-nw" + "-pf" #$pid-file ifaces)))) + (and (zero? (cdr (waitpid pid))) + (let loop () + (catch 'system-error + (lambda () + (call-with-input-file #$pid-file read)) + (lambda args + ;; 'dhclient' returned before PID-FILE was created, + ;; so try again. + (let ((errno (system-error-errno args))) + (if (= ENOENT errno) + (begin + (sleep 1) + (loop)) + (apply throw args)))))))))) + (stop #~(make-kill-destructor)))))) (define* (dhcp-client-service #:key (dhcp isc-dhcp)) "Return a service that runs @var{dhcp}, a Dynamic Host Configuration Protocol (DHCP) client, on all the non-loopback network interfaces." - - (define dhclient - #~(string-append #$dhcp "/sbin/dhclient")) - - (define pid-file - "/var/run/dhclient.pid") - - (with-monad %store-monad - (return (service - (documentation "Set up networking via DHCP.") - (requirement '(user-processes udev)) - - ;; XXX: Running with '-nw' ("no wait") avoids blocking for a - ;; minute when networking is unavailable, but also means that the - ;; interface is not up yet when 'start' completes. To wait for - ;; the interface to be ready, one should instead monitor udev - ;; events. - (provision '(networking)) - - (start #~(lambda _ - ;; When invoked without any arguments, 'dhclient' - ;; discovers all non-loopback interfaces *that are - ;; up*. However, the relevant interfaces are - ;; typically down at this point. Thus we perform our - ;; own interface discovery here. - (define valid? - (negate loopback-network-interface?)) - (define ifaces - (filter valid? (all-network-interface-names))) - - ;; XXX: Make sure the interfaces are up so that - ;; 'dhclient' can actually send/receive over them. - (for-each set-network-interface-up ifaces) - - (false-if-exception (delete-file #$pid-file)) - (let ((pid (fork+exec-command - (cons* #$dhclient "-nw" - "-pf" #$pid-file ifaces)))) - (and (zero? (cdr (waitpid pid))) - (let loop () - (catch 'system-error - (lambda () - (call-with-input-file #$pid-file read)) - (lambda args - ;; 'dhclient' returned before PID-FILE - ;; was created, so try again. - (let ((errno (system-error-errno args))) - (if (= ENOENT errno) - (begin - (sleep 1) - (loop)) - (apply throw args)))))))))) - (stop #~(make-kill-destructor)))))) + (service dhcp-client-service-type dhcp)) (define %ntp-servers ;; Default set of NTP servers. @@ -205,19 +228,30 @@ Protocol (DHCP) client, on all the non-loopback network interfaces." "1.pool.ntp.org" "2.pool.ntp.org")) -(define* (ntp-service #:key (ntp ntp) - (servers %ntp-servers)) - "Return a service that runs the daemon from @var{ntp}, the -@uref{http://www.ntp.org, Network Time Protocol package}. The daemon will -keep the system clock synchronized with that of @var{servers}." - ;; TODO: Add authentication support. - - (define config - (string-append "driftfile /var/run/ntp.drift\n" - (string-join (map (cut string-append "server " <>) - servers) - "\n") - " + +;;; +;;; NTP. +;;; + +;; TODO: Export. +(define-record-type* <ntp-configuration> + ntp-configuration make-ntp-configuration + ntp-configuration? + (ntp ntp-configuration-ntp + (default ntp)) + (servers ntp-configuration-servers)) + +(define ntp-dmd-service + (match-lambda + (($ <ntp-configuration> ntp servers) + (let () + ;; TODO: Add authentication support. + (define config + (string-append "driftfile /var/run/ntp.drift\n" + (string-join (map (cut string-append "server " <>) + servers) + "\n") + " # Disable status queries as a workaround for CVE-2013-5211: # <http://support.ntp.org/bin/view/Main/SecurityNotice#DRDoS_Amplification_Attack_using>. restrict default kod nomodify notrap nopeer noquery @@ -227,57 +261,154 @@ restrict -6 default kod nomodify notrap nopeer noquery restrict 127.0.0.1 restrict -6 ::1\n")) - (mlet %store-monad ((ntpd.conf (text-file "ntpd.conf" config))) - (return - (service - (provision '(ntpd)) - (documentation "Run the Network Time Protocol (NTP) daemon.") - (requirement '(user-processes networking)) - (start #~(make-forkexec-constructor - (list (string-append #$ntp "/bin/ntpd") "-n" - "-c" #$ntpd.conf - "-u" "ntpd"))) - (stop #~(make-kill-destructor)) - (user-accounts (list (user-account - (name "ntpd") - (group "nogroup") - (system? #t) - (comment "NTP daemon user") - (home-directory "/var/empty") - (shell - #~(string-append #$shadow "/sbin/nologin"))))))))) + (define ntpd.conf + (plain-file "ntpd.conf" config)) + + (list (dmd-service + (provision '(ntpd)) + (documentation "Run the Network Time Protocol (NTP) daemon.") + (requirement '(user-processes networking)) + (start #~(make-forkexec-constructor + (list (string-append #$ntp "/bin/ntpd") "-n" + "-c" #$ntpd.conf "-u" "ntpd"))) + (stop #~(make-kill-destructor)))))))) + +(define %ntp-accounts + (list (user-account + (name "ntpd") + (group "nogroup") + (system? #t) + (comment "NTP daemon user") + (home-directory "/var/empty") + (shell #~(string-append #$shadow "/sbin/nologin"))))) + +(define ntp-service-type + (service-type (name 'ntp) + (extensions + (list (service-extension dmd-root-service-type + ntp-dmd-service) + (service-extension account-service-type + (const %ntp-accounts)))))) + +(define* (ntp-service #:key (ntp ntp) + (servers %ntp-servers)) + "Return a service that runs the daemon from @var{ntp}, the +@uref{http://www.ntp.org, Network Time Protocol package}. The daemon will +keep the system clock synchronized with that of @var{servers}." + (service ntp-service-type + (ntp-configuration (ntp ntp) (servers servers)))) + + +;;; +;;; Tor. +;;; + +(define %tor-accounts + ;; User account and groups for Tor. + (list (user-group (name "tor") (system? #t)) + (user-account + (name "tor") + (group "tor") + (system? #t) + (comment "Tor daemon user") + (home-directory "/var/empty") + (shell #~(string-append #$shadow "/sbin/nologin"))))) + +(define (tor-dmd-service tor) + "Return a <dmd-service> running TOR." + (let ((torrc (plain-file "torrc" "User tor\n"))) + (list (dmd-service + (provision '(tor)) + + ;; Tor needs at least one network interface to be up, hence the + ;; dependency on 'loopback'. + (requirement '(user-processes loopback)) + + (start #~(make-forkexec-constructor + (list (string-append #$tor "/bin/tor") "-f" #$torrc))) + (stop #~(make-kill-destructor)) + (documentation "Run the Tor anonymous network overlay."))))) + +(define tor-service-type + (service-type (name 'tor) + (extensions + (list (service-extension dmd-root-service-type + tor-dmd-service) + (service-extension account-service-type + (const %tor-accounts)))))) (define* (tor-service #:key (tor tor)) "Return a service to run the @uref{https://torproject.org,Tor} daemon. The daemon runs with the default settings (in particular the default exit policy) as the @code{tor} unprivileged user." - (mlet %store-monad ((torrc (text-file "torrc" "User tor\n"))) - (return - (service - (provision '(tor)) - - ;; Tor needs at least one network interface to be up, hence the - ;; dependency on 'loopback'. - (requirement '(user-processes loopback)) - - (start #~(make-forkexec-constructor - (list (string-append #$tor "/bin/tor") "-f" #$torrc))) - (stop #~(make-kill-destructor)) - - (user-groups (list (user-group - (name "tor") - (system? #t)))) - (user-accounts (list (user-account - (name "tor") - (group "tor") - (system? #t) - (comment "Tor daemon user") - (home-directory "/var/empty") - (shell - #~(string-append #$shadow "/sbin/nologin"))))) - - (documentation "Run the Tor anonymous network overlay."))))) + (service tor-service-type tor)) + + +;;; +;;; BitlBee. +;;; + +(define-record-type* <bitlbee-configuration> + bitlbee-configuration make-bitlbee-configuration + bitlbee-configuration? + (bitlbee bitlbee-configuration-bitlbee + (default bitlbee)) + (interface bitlbee-configuration-interface) + (port bitlbee-configuration-port) + (extra-settings bitlbee-configuration-extra-settings)) + +(define bitlbee-dmd-service + (match-lambda + (($ <bitlbee-configuration> bitlbee interface port extra-settings) + (let ((conf (plain-file "bitlbee.conf" + (string-append " + [settings] + User = bitlbee + ConfigDir = /var/lib/bitlbee + DaemonInterface = " interface " + DaemonPort = " (number->string port) " +" extra-settings)))) + + (list (dmd-service + (provision '(bitlbee)) + (requirement '(user-processes loopback)) + (start #~(make-forkexec-constructor + (list (string-append #$bitlbee "/sbin/bitlbee") + "-n" "-F" "-u" "bitlbee" "-c" #$conf))) + (stop #~(make-kill-destructor)))))))) + +(define %bitlbee-accounts + ;; User group and account to run BitlBee. + (list (user-group (name "bitlbee") (system? #t)) + (user-account + (name "bitlbee") + (group "bitlbee") + (system? #t) + (comment "BitlBee daemon user") + (home-directory "/var/empty") + (shell #~(string-append #$shadow "/sbin/nologin"))))) + +(define %bitlbee-activation + ;; Activation gexp for BitlBee. + #~(begin + (use-modules (guix build utils)) + + ;; This directory is used to store OTR data. + (mkdir-p "/var/lib/bitlbee") + (let ((user (getpwnam "bitlbee"))) + (chown "/var/lib/bitlbee" + (passwd:uid user) (passwd:gid user))))) + +(define bitlbee-service-type + (service-type (name 'bitlbee) + (extensions + (list (service-extension dmd-root-service-type + bitlbee-dmd-service) + (service-extension account-service-type + (const %bitlbee-accounts)) + (service-extension activation-service-type + (const %bitlbee-activation)))))) (define* (bitlbee-service #:key (bitlbee bitlbee) (interface "127.0.0.1") (port 6667) @@ -292,60 +423,52 @@ come from any networking interface. In addition, @var{extra-settings} specifies a string to append to the configuration file." - (mlet %store-monad ((conf (text-file "bitlbee.conf" - (string-append " - [settings] - User = bitlbee - ConfigDir = /var/lib/bitlbee - DaemonInterface = " interface " - DaemonPort = " (number->string port) " -" extra-settings)))) - (return - (service - (provision '(bitlbee)) - (requirement '(user-processes loopback)) - (activate #~(begin - (use-modules (guix build utils)) - - ;; This directory is used to store OTR data. - (mkdir-p "/var/lib/bitlbee") - (let ((user (getpwnam "bitlbee"))) - (chown "/var/lib/bitlbee" - (passwd:uid user) (passwd:gid user))))) - (start #~(make-forkexec-constructor - (list (string-append #$bitlbee "/sbin/bitlbee") - "-n" "-F" "-u" "bitlbee" "-c" #$conf))) - (stop #~(make-kill-destructor)) - (user-groups (list (user-group (name "bitlbee") (system? #t)))) - (user-accounts (list (user-account - (name "bitlbee") - (group "bitlbee") - (system? #t) - (comment "BitlBee daemon user") - (home-directory "/var/empty") - (shell #~(string-append #$shadow - "/sbin/nologin"))))))))) + (service bitlbee-service-type + (bitlbee-configuration + (bitlbee bitlbee) + (interface interface) (port port) + (extra-settings extra-settings)))) + + +;;; +;;; Wicd. +;;; + +(define %wicd-activation + ;; Activation gexp for Wicd. + #~(begin + (use-modules (guix build utils)) + + (mkdir-p "/etc/wicd") + (let ((file-name "/etc/wicd/dhclient.conf.template.default")) + (unless (file-exists? file-name) + (copy-file (string-append #$wicd file-name) + file-name))))) + +(define (wicd-dmd-service wicd) + "Return a dmd service for WICD." + (list (dmd-service + (documentation "Run the Wicd network manager.") + (provision '(networking)) + (requirement '(user-processes dbus-system loopback)) + (start #~(make-forkexec-constructor + (list (string-append #$wicd "/sbin/wicd") + "--no-daemon"))) + (stop #~(make-kill-destructor))))) + +(define wicd-service-type + (service-type (name 'wicd) + (extensions + (list (service-extension dmd-root-service-type + wicd-dmd-service) + (service-extension dbus-root-service-type + list) + (service-extension activation-service-type + (const %wicd-activation)))))) (define* (wicd-service #:key (wicd wicd)) "Return a service that runs @url{https://launchpad.net/wicd,Wicd}, a network manager that aims to simplify wired and wireless networking." - (with-monad %store-monad - (return - (service - (documentation "Run the Wicd network manager.") - (provision '(networking)) - (requirement '(user-processes dbus-system loopback)) - (start #~(make-forkexec-constructor - (list (string-append #$wicd "/sbin/wicd") - "--no-daemon"))) - (stop #~(make-kill-destructor)) - (activate - #~(begin - (use-modules (guix build utils)) - (mkdir-p "/etc/wicd") - (let ((file-name "/etc/wicd/dhclient.conf.template.default")) - (unless (file-exists? file-name) - (copy-file (string-append #$wicd file-name) - file-name))))))))) + (service wicd-service-type wicd)) ;;; networking.scm ends here diff --git a/gnu/services/ssh.scm b/gnu/services/ssh.scm index e2f85421e9..d3a6cfb33a 100644 --- a/gnu/services/ssh.scm +++ b/gnu/services/ssh.scm @@ -18,9 +18,9 @@ (define-module (gnu services ssh) #:use-module (guix gexp) - #:use-module (guix store) - #:use-module (guix monads) + #:use-module (guix records) #:use-module (gnu services) + #:use-module (gnu services dmd) #:use-module (gnu system linux) ; 'pam-service' #:use-module (gnu packages lsh) #:export (lsh-service)) @@ -31,11 +31,32 @@ ;;; ;;; Code: +;; TODO: Export. +(define-record-type* <lsh-configuration> + lsh-configuration make-lsh-configuration + lsh-configuration? + (lsh lsh-configuration-lsh + (default lsh)) + (daemonic? lsh-configuration-daemonic?) + (host-key lsh-configuration-host-key) + (interfaces lsh-configuration-interfaces) + (port-number lsh-configuration-port-number) + (allow-empty-passwords? lsh-configuration-allow-empty-passwords?) + (root-login? lsh-configuration-root-login?) + (syslog-output? lsh-configuration-syslog-output?) + (pid-file? lsh-configuration-pid-file?) + (pid-file lsh-configuration-pid-file) + (x11-forwarding? lsh-configuration-x11-forwarding?) + (tcp/ip-forwarding? lsh-configuration-tcp/ip-forwarding?) + (password-authentication? lsh-configuration-password-authentication?) + (public-key-authentication? lsh-configuration-public-key-authentication?) + (initialize? lsh-configuration-initialize?)) + (define %yarrow-seed "/var/spool/lsh/yarrow-seed-file") -(define (activation lsh host-key) - "Return the gexp to activate the LSH service for HOST-KEY." +(define (lsh-initialization lsh host-key) + "Return the gexp to initialize the LSH service for HOST-KEY." #~(begin (unless (file-exists? #$%yarrow-seed) (system* (string-append #$lsh "/bin/lsh-make-seed") @@ -71,6 +92,88 @@ (waitpid keygen) (waitpid write-key)))))))))) +(define (lsh-activation config) + "Return the activation gexp for CONFIG." + #~(begin + (use-modules (guix build utils)) + (mkdir-p "/var/spool/lsh") + #$(if (lsh-configuration-initialize? config) + (lsh-initialization (lsh-configuration-lsh config) + (lsh-configuration-host-key config)) + #t))) + +(define (lsh-dmd-service config) + "Return a <dmd-service> for lsh with CONFIG." + (define lsh (lsh-configuration-lsh config)) + (define pid-file (lsh-configuration-pid-file config)) + (define pid-file? (lsh-configuration-pid-file? config)) + (define daemonic? (lsh-configuration-daemonic? config)) + (define interfaces (lsh-configuration-interfaces config)) + + (define lsh-command + (append + (cons #~(string-append #$lsh "/sbin/lshd") + (if daemonic? + (let ((syslog (if (lsh-configuration-syslog-output? config) + '() + (list "--no-syslog")))) + (cons "--daemonic" + (if pid-file? + (cons #~(string-append "--pid-file=" #$pid-file) + syslog) + (cons "--no-pid-file" syslog)))) + (if pid-file? + (list #~(string-append "--pid-file=" #$pid-file)) + '()))) + (cons* #~(string-append "--host-key=" + #$(lsh-configuration-host-key config)) + #~(string-append "--password-helper=" #$lsh "/sbin/lsh-pam-checkpw") + #~(string-append "--subsystems=sftp=" #$lsh "/sbin/sftp-server") + "-p" (number->string (lsh-configuration-port-number config)) + (if (lsh-configuration-password-authentication? config) + "--password" "--no-password") + (if (lsh-configuration-public-key-authentication? config) + "--publickey" "--no-publickey") + (if (lsh-configuration-root-login? config) + "--root-login" "--no-root-login") + (if (lsh-configuration-x11-forwarding? config) + "--x11-forward" "--no-x11-forward") + (if (lsh-configuration-tcp/ip-forwarding? config) + "--tcpip-forward" "--no-tcpip-forward") + (if (null? interfaces) + '() + (list (string-append "--interfaces=" + (string-join interfaces ","))))))) + + (define requires + (if (and daemonic? (lsh-configuration-syslog-output? config)) + '(networking syslogd) + '(networking))) + + (list (dmd-service + (documentation "GNU lsh SSH server") + (provision '(ssh-daemon)) + (requirement requires) + (start #~(make-forkexec-constructor (list #$@lsh-command))) + (stop #~(make-kill-destructor))))) + +(define (lsh-pam-services config) + "Return a list of <pam-services> for lshd with CONFIG." + (list (unix-pam-service + "lshd" + #:allow-empty-passwords? + (lsh-configuration-allow-empty-passwords? config)))) + +(define lsh-service-type + (service-type (name 'lsh) + (extensions + (list (service-extension dmd-root-service-type + lsh-dmd-service) + (service-extension pam-root-service-type + lsh-pam-services) + (service-extension activation-service-type + lsh-activation))))) + (define* (lsh-service #:key (lsh lsh) (daemonic? #t) @@ -115,59 +218,20 @@ passwords, and @var{root-login?} specifies whether to accept log-ins as root. The other options should be self-descriptive." - (define lsh-command - (append - (cons #~(string-append #$lsh "/sbin/lshd") - (if daemonic? - (let ((syslog (if syslog-output? '() - (list "--no-syslog")))) - (cons "--daemonic" - (if pid-file? - (cons #~(string-append "--pid-file=" #$pid-file) - syslog) - (cons "--no-pid-file" syslog)))) - (if pid-file? - (list #~(string-append "--pid-file=" #$pid-file)) - '()))) - (cons* #~(string-append "--host-key=" #$host-key) - #~(string-append "--password-helper=" #$lsh "/sbin/lsh-pam-checkpw") - #~(string-append "--subsystems=sftp=" #$lsh "/sbin/sftp-server") - "-p" (number->string port-number) - (if password-authentication? "--password" "--no-password") - (if public-key-authentication? - "--publickey" "--no-publickey") - (if root-login? - "--root-login" "--no-root-login") - (if x11-forwarding? - "--x11-forward" "--no-x11-forward") - (if tcp/ip-forwarding? - "--tcpip-forward" "--no-tcpip-forward") - (if (null? interfaces) - '() - (list (string-append "--interfaces=" - (string-join interfaces ","))))))) - - (define requires - (if (and daemonic? syslog-output?) - '(networking syslogd) - '(networking))) - - (with-monad %store-monad - (return (service - (documentation "GNU lsh SSH server") - (provision '(ssh-daemon)) - (requirement requires) - (start #~(make-forkexec-constructor (list #$@lsh-command))) - (stop #~(make-kill-destructor)) - (pam-services - (list (unix-pam-service - "lshd" - #:allow-empty-passwords? allow-empty-passwords?))) - (activate #~(begin - (use-modules (guix build utils)) - (mkdir-p "/var/spool/lsh") - #$(if initialize? - (activation lsh host-key) - #t))))))) + (service lsh-service-type + (lsh-configuration (lsh lsh) (daemonic? daemonic?) + (host-key host-key) (interfaces interfaces) + (port-number port-number) + (allow-empty-passwords? allow-empty-passwords?) + (root-login? root-login?) + (syslog-output? syslog-output?) + (pid-file? pid-file?) (pid-file pid-file) + (x11-forwarding? x11-forwarding?) + (tcp/ip-forwarding? tcp/ip-forwarding?) + (password-authentication? + password-authentication?) + (public-key-authentication? + public-key-authentication?) + (initialize? initialize?)))) ;;; ssh.scm ends here diff --git a/gnu/services/web.scm b/gnu/services/web.scm index 2db5b76ce4..84bb30d8fd 100644 --- a/gnu/services/web.scm +++ b/gnu/services/web.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 David Thompson <davet@gnu.org> +;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,13 +19,13 @@ (define-module (gnu services web) #:use-module (gnu services) + #:use-module (gnu services dmd) #:use-module (gnu system shadow) #:use-module (gnu packages admin) #:use-module (gnu packages web) #:use-module (guix records) - #:use-module (guix monads) - #:use-module (guix store) #:use-module (guix gexp) + #:use-module (ice-9 match) #:export (nginx-service)) ;;; Commentary: @@ -33,6 +34,14 @@ ;;; ;;; Code: +(define-record-type* <nginx-configuration> + nginx-configuration make-nginx-configuration + nginx-configuration? + (nginx nginx-configuration-nginx) ;<package> + (log-directory nginx-configuration-log-directory) ;string + (run-directory nginx-configuration-run-directory) ;string + (file nginx-configuration-file)) ;string | file-like + (define (default-nginx-config log-directory run-directory) (plain-file "nginx.conf" (string-append @@ -46,6 +55,58 @@ "}\n" "events {}\n"))) +(define %nginx-accounts + (list (user-group (name "nginx") (system? #t)) + (user-account + (name "nginx") + (group "nginx") + (system? #t) + (comment "nginx server user") + (home-directory "/var/empty") + (shell #~(string-append #$shadow "/sbin/nologin"))))) + +(define nginx-activation + (match-lambda + (($ <nginx-configuration> nginx log-directory run-directory config-file) + #~(begin + (use-modules (guix build utils)) + + (format #t "creating nginx log directory '~a'~%" #$log-directory) + (mkdir-p #$log-directory) + (format #t "creating nginx run directory '~a'~%" #$run-directory) + (mkdir-p #$run-directory) + ;; Check configuration file syntax. + (system* (string-append #$nginx "/bin/nginx") + "-c" #$config-file "-t"))))) + +(define nginx-dmd-service + (match-lambda + (($ <nginx-configuration> nginx log-directory run-directory config-file) + (let* ((nginx-binary #~(string-append #$nginx "/sbin/nginx")) + (nginx-action + (lambda args + #~(lambda _ + (zero? + (system* #$nginx-binary "-c" #$config-file #$@args)))))) + + ;; TODO: Add 'reload' action. + (list (dmd-service + (provision '(nginx)) + (documentation "Run the nginx daemon.") + (requirement '(user-processes loopback)) + (start (nginx-action "-p" run-directory)) + (stop (nginx-action "-s" "stop")))))))) + +(define nginx-service-type + (service-type (name 'nginx) + (extensions + (list (service-extension dmd-root-service-type + nginx-dmd-service) + (service-extension activation-service-type + nginx-activation) + (service-extension account-service-type + (const %nginx-accounts)))))) + (define* (nginx-service #:key (nginx nginx) (log-directory "/var/log/nginx") (run-directory "/var/run/nginx") @@ -55,43 +116,9 @@ The nginx daemon loads its runtime configuration from CONFIG-FIGLE, stores log files in LOG-DIRECTORY, and stores temporary runtime files in RUN-DIRECTORY." - (define nginx-binary - #~(string-append #$nginx "/sbin/nginx")) - - (define (nginx-action . args) - #~(lambda _ - (zero? - (system* #$nginx-binary "-c" #$config-file #$@args)))) - - (define activate - #~(begin - (use-modules (guix build utils)) - (format #t "creating nginx log directory '~a'~%" #$log-directory) - (mkdir-p #$log-directory) - (format #t "creating nginx run directory '~a'~%" #$run-directory) - (mkdir-p #$run-directory) - ;; Check configuration file syntax. - (system* #$nginx-binary "-c" #$config-file "-t"))) - - (define nologin #~(string-append #$shadow "/sbin/nologin")) - - ;; TODO: Add 'reload' action. - (mbegin %store-monad - (return - (service - (provision '(nginx)) - (documentation "Run the nginx daemon.") - (requirement '(user-processes loopback)) - (start (nginx-action "-p" run-directory)) - (stop (nginx-action "-s" "stop")) - (activate activate) - (user-groups (list (user-group - (name "nginx") - (system? #t)))) - (user-accounts (list (user-account - (name "nginx") - (group "nginx") - (system? #t) - (comment "nginx server user") - (home-directory "/var/empty") - (shell nologin)))))))) + (service nginx-service-type + (nginx-configuration + (nginx nginx) + (log-directory log-directory) + (run-directory run-directory) + (file config-file)))) diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm index 9ee88170e4..812cb3f725 100644 --- a/gnu/services/xorg.scm +++ b/gnu/services/xorg.scm @@ -20,6 +20,7 @@ (define-module (gnu services xorg) #:use-module (gnu artwork) #:use-module (gnu services) + #:use-module (gnu services dmd) #:use-module (gnu system linux) ; 'pam-service' #:use-module ((gnu packages base) #:select (canonical-package)) #:use-module (gnu packages guile) @@ -31,7 +32,6 @@ #:use-module (gnu packages bash) #:use-module (guix gexp) #:use-module (guix store) - #:use-module (guix monads) #:use-module (guix derivations) #:use-module (guix records) #:use-module (srfi srfi-1) @@ -63,8 +63,8 @@ appropriate screen resolution; otherwise, it must be a list of resolutions---e.g., @code{((1024 768) (640 480))}. Last, @var{extra-config} is a list of strings or objects appended to the -@code{text-file*} argument list. It is used to pass extra text to be added -verbatim to the configuration file." +@code{mixed-text-file} argument list. It is used to pass extra text to be +added verbatim to the configuration file." (define (device-section driver) (string-append " Section \"Device\" @@ -87,7 +87,7 @@ Section \"Screen\" EndSubSection EndSection")) - (apply text-file* "xserver.conf" " + (apply mixed-text-file "xserver.conf" " Section \"Files\" FontPath \"" font-adobe75dpi "/share/fonts/X11/75dpi\" ModulePath \"" xf86-video-vesa "/lib/xorg/modules/drivers\" @@ -128,7 +128,7 @@ EndSection (define* (xorg-start-command #:key (guile (canonical-package guile-2.0)) - configuration-file + (configuration-file (xorg-configuration-file)) (xorg-server xorg-server)) "Return a derivation that builds a @var{guile} script to start the X server from @var{xorg-server}. @var{configuration-file} is the server configuration @@ -136,27 +136,24 @@ file or a derivation that builds it; when omitted, the result of @code{xorg-configuration-file} is used. Usually the X server is started by a login manager." - (mlet %store-monad ((config (if configuration-file - (return configuration-file) - (xorg-configuration-file)))) - (define script - ;; Write a small wrapper around the X server. - #~(begin - (setenv "XORG_DRI_DRIVER_PATH" (string-append #$mesa "/lib/dri")) - (setenv "XKB_BINDIR" (string-append #$xkbcomp "/bin")) - - (apply execl (string-append #$xorg-server "/bin/X") - (string-append #$xorg-server "/bin/X") ;argv[0] - "-logverbose" "-verbose" - "-xkbdir" (string-append #$xkeyboard-config "/share/X11/xkb") - "-config" #$config - "-nolisten" "tcp" "-terminate" - - ;; Note: SLiM and other display managers add the - ;; '-auth' flag by themselves. - (cdr (command-line))))) - - (gexp->script "start-xorg" script))) + (define exp + ;; Write a small wrapper around the X server. + #~(begin + (setenv "XORG_DRI_DRIVER_PATH" (string-append #$mesa "/lib/dri")) + (setenv "XKB_BINDIR" (string-append #$xkbcomp "/bin")) + + (apply execl (string-append #$xorg-server "/bin/X") + (string-append #$xorg-server "/bin/X") ;argv[0] + "-logverbose" "-verbose" + "-xkbdir" (string-append #$xkeyboard-config "/share/X11/xkb") + "-config" #$configuration-file + "-nolisten" "tcp" "-terminate" + + ;; Note: SLiM and other display managers add the + ;; '-auth' flag by themselves. + (cdr (command-line))))) + + (program-file "start-xorg" exp)) (define* (xinitrc #:key (guile (canonical-package guile-2.0)) @@ -200,7 +197,7 @@ which should be passed to this script as the first argument. If not, the (exec-from-login-shell xsession-file session) ;; Otherwise, start the specified session. (exec-from-login-shell session))))) - (gexp->script "xinitrc" builder)) + (program-file "xinitrc" builder)) ;;; @@ -216,6 +213,95 @@ which should be passed to this script as the first argument. If not, the ;; contains the actual theme files. "0.x") +(define-record-type* <slim-configuration> + slim-configuration make-slim-configuration + slim-configuration? + (slim slim-configuration-slim + (default slim)) + (allow-empty-passwords? slim-configuration-allow-empty-passwords?) + (auto-login? slim-configuration-auto-login?) + (default-user slim-configuration-default-user) + (theme slim-configuration-theme) + (theme-name slim-configuration-theme-name) + (xauth slim-configuration-xauth + (default xauth)) + (dmd slim-configuration-dmd + (default dmd)) + (bash slim-configuration-bash + (default bash)) + (auto-login-session slim-configuration-auto-login-session) + (startx slim-configuration-startx)) + +(define (slim-pam-service config) + "Return a PAM service for @command{slim}." + (list (unix-pam-service + "slim" + #:allow-empty-passwords? + (slim-configuration-allow-empty-passwords? config)))) + +(define (slim-dmd-service config) + (define slim.cfg + (let ((xinitrc (xinitrc #:fallback-session + (slim-configuration-auto-login-session config))) + (slim (slim-configuration-slim config)) + (xauth (slim-configuration-xauth config)) + (startx (slim-configuration-startx config)) + (dmd (slim-configuration-dmd config)) + (theme-name (slim-configuration-theme-name config))) + (mixed-text-file "slim.cfg" " +default_path /run/current-system/profile/bin +default_xserver " startx " +xserver_arguments :0 vt7 +xauth_path " xauth "/bin/xauth +authfile /var/run/slim.auth + +# The login command. '%session' is replaced by the chosen session name, one +# of the names specified in the 'sessions' setting: 'wmaker', 'xfce', etc. +login_cmd exec " xinitrc " %session +sessiondir /run/current-system/profile/share/xsessions +session_msg session (F1 to change): + +halt_cmd " dmd "/sbin/halt +reboot_cmd " dmd "/sbin/reboot\n" +(if (slim-configuration-auto-login? config) + (string-append "auto_login yes\ndefault_user " + (slim-configuration-default-user config) "\n") + "") +(if theme-name + (string-append "current_theme " theme-name "\n") + "")))) + + (define theme + (slim-configuration-theme config)) + + (list (dmd-service + (documentation "Xorg display server") + (provision '(xorg-server)) + (requirement '(user-processes host-name udev)) + (start + #~(lambda () + ;; A stale lock file can prevent SLiM from starting, so remove it to + ;; be on the safe side. + (false-if-exception (delete-file "/var/run/slim.lock")) + + (fork+exec-command + (list (string-append #$slim "/bin/slim") "-nodaemon") + #:environment-variables + (list (string-append "SLIM_CFGFILE=" #$slim.cfg) + #$@(if theme + (list #~(string-append "SLIM_THEMESDIR=" #$theme)) + #~()))))) + (stop #~(make-kill-destructor)) + (respawn? #t)))) + +(define slim-service-type + (service-type (name 'slim) + (extensions + (list (service-extension dmd-root-service-type + slim-dmd-service) + (service-extension pam-root-service-type + slim-pam-service))))) + (define* (slim-service #:key (slim slim) (allow-empty-passwords? #t) auto-login? (default-user "") @@ -224,7 +310,7 @@ which should be passed to this script as the first argument. If not, the (xauth xauth) (dmd dmd) (bash bash) (auto-login-session #~(string-append #$windowmaker "/bin/wmaker")) - startx) + (startx (xorg-start-command))) "Return a service that spawns the SLiM graphical login manager, which in turn starts the X display server with @var{startx}, a command as returned by @code{xorg-start-command}. @@ -250,61 +336,14 @@ If @var{theme} is @code{#f}, the use the default log-in theme; otherwise @var{theme} must be a gexp denoting the name of a directory containing the theme to use. In that case, @var{theme-name} specifies the name of the theme." - - (define (slim.cfg) - (mlet %store-monad ((startx (if startx - (return startx) - (xorg-start-command))) - (xinitrc (xinitrc #:fallback-session - auto-login-session))) - (text-file* "slim.cfg" " -default_path /run/current-system/profile/bin -default_xserver " startx " -xserver_arguments :0 vt7 -xauth_path " xauth "/bin/xauth -authfile /var/run/slim.auth - -# The login command. '%session' is replaced by the chosen session name, one -# of the names specified in the 'sessions' setting: 'wmaker', 'xfce', etc. -login_cmd exec " xinitrc " %session -sessiondir /run/current-system/profile/share/xsessions -session_msg session (F1 to change): - -halt_cmd " dmd "/sbin/halt -reboot_cmd " dmd "/sbin/reboot -" -(if auto-login? - (string-append "auto_login yes\ndefault_user " default-user "\n") - "") -(if theme-name - (string-append "current_theme " theme-name "\n") - "")))) - - (mlet %store-monad ((slim.cfg (slim.cfg))) - (return - (service - (documentation "Xorg display server") - (provision '(xorg-server)) - (requirement '(user-processes host-name udev)) - (start - #~(lambda () - ;; A stale lock file can prevent SLiM from starting, so remove it - ;; to be on the safe side. - (false-if-exception (delete-file "/var/run/slim.lock")) - - (fork+exec-command - (list (string-append #$slim "/bin/slim") "-nodaemon") - #:environment-variables - (list (string-append "SLIM_CFGFILE=" #$slim.cfg) - #$@(if theme - (list #~(string-append "SLIM_THEMESDIR=" #$theme)) - #~()))))) - (stop #~(make-kill-destructor)) - (respawn? #t) - (pam-services - ;; Tell PAM about 'slim'. - (list (unix-pam-service - "slim" - #:allow-empty-passwords? allow-empty-passwords?))))))) + (service slim-service-type + (slim-configuration + (slim slim) + (allow-empty-passwords? allow-empty-passwords?) + (auto-login? auto-login?) (default-user default-user) + (theme theme) (theme-name theme-name) + (xauth xauth) (dmd dmd) (bash bash) + (auto-login-session auto-login-session) + (startx startx)))) ;;; xorg.scm ends here |