diff options
Diffstat (limited to 'gnu/services/base.scm')
| -rw-r--r-- | gnu/services/base.scm | 222 |
1 files changed, 204 insertions, 18 deletions
diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 336cc4dec9..a86e8e04c7 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Alex Kost <alezost@gmail.com> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> +;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,12 +24,12 @@ #:use-module (gnu services) #:use-module (gnu services dmd) #:use-module (gnu services networking) + #:use-module (gnu system pam) #: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)) + #:select (eudev kbd e2fsprogs lvm2 fuse alsa-utils crda gpm)) #:use-module ((gnu packages base) #:select (canonical-package glibc)) #:use-module (gnu packages package-management) @@ -48,15 +49,23 @@ device-mapping-service swap-service user-processes-service + session-environment-service + session-environment-service-type host-name-service console-keymap-service console-font-service + + udev-configuration + udev-configuration? + udev-configuration-rules udev-service-type udev-service + udev-rule mingetty-configuration mingetty-configuration? mingetty-service + mingetty-service-type %nscd-default-caches %nscd-default-configuration @@ -74,6 +83,13 @@ guix-configuration guix-configuration? guix-service + guix-service-type + guix-publish-configuration + guix-publish-configuration? + guix-publish-service + guix-publish-service-type + gpm-service-type + gpm-service %base-services)) @@ -142,6 +158,18 @@ FILE-SYSTEM." (symbol-append 'file-system- (string->symbol (file-system-mount-point file-system)))) +(define (mapped-device->dmd-service-name md) + "Return the symbol that denotes the dmd service of MD, a <mapped-device>." + (symbol-append 'device-mapping- + (string->symbol (mapped-device-target md)))) + +(define dependency->dmd-service-name + (match-lambda + ((? mapped-device? md) + (mapped-device->dmd-service-name md)) + ((? file-system? fs) + (file-system->dmd-service-name fs)))) + (define file-system-service-type ;; TODO(?): Make this an extensible service that takes <file-system> objects ;; and returns a list of <dmd-service>. @@ -158,7 +186,7 @@ FILE-SYSTEM." (dmd-service (provision (list (file-system->dmd-service-name file-system))) (requirement `(root-file-system - ,@(map file-system->dmd-service-name dependencies))) + ,@(map dependency->dmd-service-name dependencies))) (documentation "Check, mount, and unmount the given file system.") (start #~(lambda args ;; FIXME: Use or factorize with 'mount-file-system'. @@ -198,7 +226,14 @@ FILE-SYSTEM." (chdir "/") (umount #$target) - #f))))))) + #f)) + + ;; We need an additional module. + (modules `(((gnu build file-systems) + #:select (check-file-system canonicalize-device-spec)) + ,@%default-modules)) + (imported-modules `((gnu build file-systems) + ,@%default-imported-modules))))))) (define* (file-system-service file-system) "Return a service that mounts @var{file-system}, a @code{<file-system>} @@ -336,6 +371,39 @@ stopped before 'kill' is called." ;;; +;;; System-wide environment variables. +;;; + +(define (environment-variables->environment-file vars) + "Return a file for pam_env(8) that contains environment variables VARS." + (apply mixed-text-file "environment" + (append-map (match-lambda + ((key . value) + (list key "=" value "\n"))) + vars))) + +(define session-environment-service-type + (service-type + (name 'session-environment) + (extensions + (list (service-extension + etc-service-type + (lambda (vars) + (list `("environment" + ,(environment-variables->environment-file vars))))))) + (compose concatenate) + (extend append))) + +(define (session-environment-service vars) + "Return a service that builds the @file{/etc/environment}, which can be read +by PAM-aware applications to set environment variables for sessions. + +VARS should be an association list in which both the keys and the values are +strings or string-valued gexps." + (service session-environment-service-type vars)) + + +;;; ;;; Console & co. ;;; @@ -691,6 +759,11 @@ If configuration file name @var{config-file} is not specified, use some reasonable default settings." (service syslog-service-type config-file)) + +;;; +;;; Guix services. +;;; + (define* (guix-build-accounts count #:key (group "guixbuild") (first-uid 30001) @@ -751,6 +824,8 @@ failed to register hydra.gnu.org public key: ~a~%" status)))))))) (default #t)) (use-substitutes? guix-configuration-use-substitutes? ;Boolean (default #t)) + (substitute-urls guix-configuration-substitute-urls ;list of strings + (default %default-substitute-urls)) (extra-options guix-configuration-extra-options ;list of strings (default '())) (lsof guix-configuration-lsof ;<package> @@ -765,7 +840,8 @@ failed to register hydra.gnu.org public key: ~a~%" status)))))))) "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) + use-substitutes? substitute-urls extra-options + lsof lsh) (list (dmd-service (documentation "Run the Guix daemon.") (provision '(guix-daemon)) @@ -777,6 +853,7 @@ failed to register hydra.gnu.org public key: ~a~%" status)))))))) #$@(if use-substitutes? '() '("--no-substitutes")) + "--substitute-urls" #$(string-join substitute-urls) #$@extra-options) ;; Add 'lsof' (for the GC) and 'lsh' (for offloading) to the @@ -824,6 +901,58 @@ failed to register hydra.gnu.org public key: ~a~%" status)))))))) @var{config}." (service guix-service-type config)) + +(define-record-type* <guix-publish-configuration> + guix-publish-configuration make-guix-publish-configuration + guix-publish-configuration? + (guix guix-publish-configuration-guix ;package + (default guix)) + (port guix-publish-configuration-port ;number + (default 80)) + (host guix-publish-configuration-host ;string + (default "localhost"))) + +(define guix-publish-dmd-service + (match-lambda + (($ <guix-publish-configuration> guix port host) + (list (dmd-service + (provision '(guix-publish)) + (requirement '(guix-daemon)) + (start #~(make-forkexec-constructor + (list (string-append #$guix "/bin/guix") + "publish" "-u" "guix-publish" + "-p" #$(number->string port) + (string-append "--listen=" #$host)))) + (stop #~(make-kill-destructor))))))) + +(define %guix-publish-accounts + (list (user-group (name "guix-publish") (system? #t)) + (user-account + (name "guix-publish") + (group "guix-publish") + (system? #t) + (comment "guix publish user") + (home-directory "/var/empty") + (shell #~(string-append #$shadow "/sbin/nologin"))))) + +(define guix-publish-service-type + (service-type (name 'guix-publish) + (extensions + (list (service-extension dmd-root-service-type + guix-publish-dmd-service) + (service-extension account-service-type + (const %guix-publish-accounts)))))) + +(define* (guix-publish-service #:key (guix guix) (port 80) (host "localhost")) + "Return a service that runs @command{guix publish} listening on @var{host} +and @var{port} (@pxref{Invoking guix publish}). + +This assumes that @file{/etc/guix} already contains a signing key pair as +created by @command{guix archive --generate-key} (@pxref{Invoking guix +archive}). If that is not the case, the service will fail to start." + (service guix-publish-service-type + (guix-publish-configuration (guix guix) (port port) (host host)))) + ;;; ;;; Udev. @@ -864,12 +993,9 @@ item of @var{packages}." #: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. - (computed-file "kvm-udev-rules" +(define (udev-rule file-name contents) + "Return a directory with a udev rule file FILE-NAME containing CONTENTS." + (computed-file file-name #~(begin (use-modules (guix build utils)) @@ -878,20 +1004,26 @@ item of @var{packages}." (mkdir-p rules.d) (call-with-output-file - (string-append rules.d "/90-kvm.rules") + (string-append rules.d "/" #$file-name) (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)))) + (display #$contents port)))) #:modules '((guix build utils)))) +(define kvm-udev-rule + ;; Return a directory with a udev rule that changes the group of /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. + + ;; Build users are part of the "kvm" group, so we can fearlessly make + ;; /dev/kvm 660 (see <http://bugs.gnu.org/18994>, for background.) + (udev-rule "90-kvm.rules" + "KERNEL==\"kvm\", GROUP=\"kvm\", MODE=\"0660\"\n")) + (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))) + (let* ((rules (udev-rules-union (cons* udev kvm-udev-rule rules))) (udev.conf (computed-file "udev.conf" #~(call-with-output-file #$output (lambda (port) @@ -1034,6 +1166,60 @@ gexp, to open it, and evaluate @var{close} to close it." "Return a service that uses @var{device} as a swap device." (service swap-service-type device)) + +(define-record-type* <gpm-configuration> + gpm-configuration make-gpm-configuration gpm-configuration? + (gpm gpm-configuration-gpm) ;package + (options gpm-configuration-options)) ;list of strings + +(define gpm-dmd-service + (match-lambda + (($ <gpm-configuration> gpm options) + (list (dmd-service + (requirement '(udev)) + (provision '(gpm)) + (start #~(lambda () + ;; 'gpm' runs in the background and sets a PID file. + ;; Note that it requires running as "root". + (false-if-exception (delete-file "/var/run/gpm.pid")) + (fork+exec-command (list (string-append #$gpm "/sbin/gpm") + #$@options)) + + ;; Wait for the PID file to appear; declare failure if + ;; it doesn't show up. + (let loop ((i 3)) + (or (file-exists? "/var/run/gpm.pid") + (if (zero? i) + #f + (begin + (sleep 1) + (loop (1- i)))))))) + + (stop #~(lambda (_) + ;; Return #f if successfully stopped. + (not (zero? (system* (string-append #$gpm "/sbin/gpm") + "-k")))))))))) + +(define gpm-service-type + (service-type (name 'gpm) + (extensions + (list (service-extension dmd-root-service-type + gpm-dmd-service))))) + +(define* (gpm-service #:key (gpm gpm) + (options '("-m" "/dev/input/mice" "-t" "ps2"))) + "Run @var{gpm}, the general-purpose mouse daemon, with the given +command-line @var{options}. GPM allows users to use the mouse in the console, +notably to select, copy, and paste text. The default value of @var{options} +uses the @code{ps2} protocol, which works for both USB and PS/2 mice. + +This service is not part of @var{%base-services}." + ;; To test in QEMU, use "-usbdevice mouse" and then, in the monitor, use + ;; "info mice" and "mouse_set X" to use the right mouse. + (service gpm-service-type + (gpm-configuration (gpm gpm) (options options)))) + + (define %base-services ;; Convenience variable holding the basic services. (let ((motd (plain-file "motd" " |