aboutsummaryrefslogtreecommitdiff
path: root/gnu/services/base.scm
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2016-09-30 12:01:32 +0200
committerLudovic Courtès <ludo@gnu.org>2016-09-30 12:05:27 +0200
commit79355ae3e84359716f5135cc7083e72246bc8bf9 (patch)
tree6b61851e2153581578bb78ef0f177b8841ee5db7 /gnu/services/base.scm
parent39d6b9c99f297e14fc4f47f002be3d40556726be (diff)
parent86d8f6d3efb8300a3354735cbf06be6c01e23243 (diff)
downloadguix-79355ae3e84359716f5135cc7083e72246bc8bf9.tar
guix-79355ae3e84359716f5135cc7083e72246bc8bf9.tar.gz
Merge branch 'master' into core-updates
Diffstat (limited to 'gnu/services/base.scm')
-rw-r--r--gnu/services/base.scm279
1 files changed, 183 insertions, 96 deletions
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index f3f6408687..afbecdb47e 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -39,6 +39,7 @@
#:use-module (gnu packages package-management)
#:use-module (gnu packages ssh)
#:use-module (gnu packages lsof)
+ #:use-module (gnu packages terminals)
#:use-module ((gnu build file-systems)
#:select (mount-flags->bit-mask))
#:use-module (guix gexp)
@@ -57,6 +58,8 @@
session-environment-service-type
host-name-service
console-keymap-service
+ %default-console-font
+ console-font-service-type
console-font-service
udev-configuration
@@ -66,6 +69,11 @@
udev-service
udev-rule
+ login-configuration
+ login-configuration?
+ login-service-type
+ login-service
+
mingetty-configuration
mingetty-configuration?
mingetty-service
@@ -82,6 +90,9 @@
nscd-service-type
nscd-service
+
+ syslog-configuration
+ syslog-configuration?
syslog-service
syslog-service-type
%default-syslog.conf
@@ -108,6 +119,11 @@
rngd-configuration?
rngd-service-type
rngd-service
+
+ kmscon-configuration
+ kmscon-configuration?
+ kmscon-service-type
+
pam-limits-service-type
pam-limits-service
@@ -513,7 +529,7 @@ stopped before 'kill' is called."
(define device (rngd-configuration-device config))
(define rngd-command
- (list #~(string-append #$rng-tools "/sbin/rngd")
+ (list (file-append rng-tools "/sbin/rngd")
"-f" "-r" device))
(shepherd-service
@@ -621,37 +637,83 @@ strings or string-valued gexps."
"Return a service to load console keymaps from @var{files}."
(service console-keymap-service-type files))
-(define console-font-service-type
- (shepherd-service-type
- 'console-font
- (match-lambda
- ((tty font)
- (let ((device (string-append "/dev/" tty)))
- (shepherd-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))))
+(define %default-console-font
+ ;; 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.
+ "LatGrkCyr-8x16")
+
+(define (console-font-shepherd-services tty+font)
+ "Return a list of Shepherd services for each pair in TTY+FONT."
+ (map (match-lambda
+ ((tty . font)
+ (let ((device (string-append "/dev/" tty)))
+ (shepherd-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)))))
+ tty+font))
- (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-type
+ (service-type (name 'console-fonts)
+ (extensions
+ (list (service-extension shepherd-root-service-type
+ console-font-shepherd-services)))
+ (compose concatenate)
+ (extend append)))
(define* (console-font-service tty #:optional (font "LatGrkCyr-8x16"))
- "Return a service that sets up Unicode support in @var{tty} and loads
+ "This procedure is deprecated in favor of @code{console-font-service-type}.
+
+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.
- (service console-font-service-type (list tty font)))
+ (simple-service (symbol-append 'console-font- (string->symbol tty))
+ console-font-service-type `((,tty . ,font))))
+
+(define %default-motd
+ (plain-file "motd" "This is the GNU operating system, welcome!\n\n"))
+
+(define-record-type* <login-configuration>
+ login-configuration make-login-configuration
+ login-configuration?
+ (motd login-configuration-motd ;file-like
+ (default %default-motd))
+ ;; Allow empty passwords by default so that first-time users can log in when
+ ;; the 'root' account has just been created.
+ (allow-empty-passwords? login-configuration-allow-empty-passwords?
+ (default #t))) ;Boolean
+
+(define (login-pam-service config)
+ "Return the list of PAM service needed for CONF."
+ ;; Let 'login' be known to PAM.
+ (list (unix-pam-service "login"
+ #:allow-empty-passwords?
+ (login-configuration-allow-empty-passwords? config)
+ #:motd
+ (login-configuration-motd config))))
+
+(define login-service-type
+ (service-type (name 'login)
+ (extensions (list (service-extension pam-root-service-type
+ login-pam-service)))))
+
+(define* (login-service #:optional (config (login-configuration)))
+ "Return a service configure login according to @var{config}, which specifies
+the message of the day, among other things."
+ (service login-service-type config))
(define-record-type* <mingetty-configuration>
mingetty-configuration make-mingetty-configuration
@@ -659,35 +721,17 @@ strings or string-valued gexps."
(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))))
+ (default #f)))
(define mingetty-shepherd-service
(match-lambda
- (($ <mingetty-configuration> mingetty tty motd auto-login login-program
- login-pause? allow-empty-passwords?)
+ (($ <mingetty-configuration> mingetty tty auto-login login-program
+ login-pause?)
(list
(shepherd-service
(documentation "Run mingetty on an tty.")
@@ -715,9 +759,7 @@ strings or string-valued gexps."
(define mingetty-service-type
(service-type (name 'mingetty)
(extensions (list (service-extension shepherd-root-service-type
- mingetty-shepherd-service)
- (service-extension pam-root-service-type
- mingetty-pam-service)))))
+ mingetty-shepherd-service)))))
(define* (mingetty-service config)
"Return a service to run mingetty according to @var{config}, which specifies
@@ -885,17 +927,27 @@ given @var{config}---an @code{<nscd-configuration>} object. @xref{Name
Service Switch}, for an example."
(service nscd-service-type config))
+
+(define-record-type* <syslog-configuration>
+ syslog-configuration make-syslog-configuration
+ syslog-configuration?
+ (syslogd syslog-configuration-syslogd
+ (default (file-append inetutils "/libexec/syslogd")))
+ (config-file syslog-configuration-config-file
+ (default %default-syslog.conf)))
+
(define syslog-service-type
(shepherd-service-type
'syslog
- (lambda (config-file)
+ (lambda (config)
(shepherd-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)))
+ (list #$(syslog-configuration-syslogd config)
+ "--rcfile" #$(syslog-configuration-config-file config))
+ #:pid-file "/var/run/syslog.pid"))
(stop #~(make-kill-destructor))))))
;; Snippet adapted from the GNU inetutils manual.
@@ -921,14 +973,14 @@ Service Switch}, for an example."
mail.* /var/log/maillog
"))
-(define* (syslog-service #:key (config-file %default-syslog.conf))
- "Return a service that runs @command{syslogd}. If configuration file
-name @var{config-file} is not specified, use some reasonable default
-settings.
+(define* (syslog-service #:optional (config (syslog-configuration)))
+ "Return a service that runs @command{syslogd} and takes
+@var{<syslog-configuration>} as a parameter.
@xref{syslogd invocation,,, inetutils, GNU Inetutils}, for more
information on the configuration file syntax."
- (service syslog-service-type config-file))
+ (service syslog-service-type config))
+
(define pam-limits-service-type
(let ((security-limits
@@ -996,7 +1048,7 @@ starting at FIRST-UID, and under GID."
(comment (format #f "Guix Build User ~2d" n))
(home-directory "/var/empty")
- (shell #~(string-append #$shadow "/sbin/nologin"))))
+ (shell (file-append shadow "/sbin/nologin"))))
1+
1))
@@ -1023,7 +1075,7 @@ failed to register hydra.gnu.org public key: ~a~%" status))))))))
(define %default-authorized-guix-keys
;; List of authorized substitute keys.
- (list #~(string-append #$guix "/share/guix/hydra.gnu.org.pub")))
+ (list (file-append guix "/share/guix/hydra.gnu.org.pub")))
(define-record-type* <guix-configuration>
guix-configuration make-guix-configuration
@@ -1154,7 +1206,7 @@ failed to register hydra.gnu.org public key: ~a~%" status))))))))
(system? #t)
(comment "guix publish user")
(home-directory "/var/empty")
- (shell #~(string-append #$shadow "/sbin/nologin")))))
+ (shell (file-append shadow "/sbin/nologin")))))
(define guix-publish-service-type
(service-type (name 'guix-publish)
@@ -1419,41 +1471,76 @@ This service is not part of @var{%base-services}."
(service gpm-service-type
(gpm-configuration (gpm gpm) (options options))))
+(define-record-type* <kmscon-configuration>
+ kmscon-configuration make-kmscon-configuration
+ kmscon-configuration?
+ (kmscon kmscon-configuration-kmscon
+ (default kmscon))
+ (virtual-terminal kmscon-configuration-virtual-terminal)
+ (login-program kmscon-configuration-login-program
+ (default #~(string-append #$shadow "/bin/login")))
+ (login-arguments kmscon-configuration-login-arguments
+ (default '("-p")))
+ (hardware-acceleration? kmscon-configuration-hardware-acceleration?
+ (default #f))) ; #t causes failure
+
+(define kmscon-service-type
+ (shepherd-service-type
+ 'kmscon
+ (lambda (config)
+ (let ((kmscon (kmscon-configuration-kmscon config))
+ (virtual-terminal (kmscon-configuration-virtual-terminal config))
+ (login-program (kmscon-configuration-login-program config))
+ (login-arguments (kmscon-configuration-login-arguments config))
+ (hardware-acceleration? (kmscon-configuration-hardware-acceleration? config)))
+
+ (define kmscon-command
+ #~(list
+ (string-append #$kmscon "/bin/kmscon") "--login"
+ "--vt" #$virtual-terminal
+ #$@(if hardware-acceleration? '("--hwaccel") '())
+ "--" #$login-program #$@login-arguments))
+
+ (shepherd-service
+ (documentation "kmscon virtual terminal")
+ (requirement '(user-processes udev dbus-system))
+ (provision (list (symbol-append 'term- (string->symbol virtual-terminal))))
+ (start #~(make-forkexec-constructor #$kmscon-command))
+ (stop #~(make-kill-destructor)))))))
+
(define %base-services
;; Convenience variable holding the basic services.
- (let ((motd (plain-file "motd" "
-This is the GNU operating system, welcome!\n\n")))
- (list (console-font-service "tty1")
- (console-font-service "tty2")
- (console-font-service "tty3")
- (console-font-service "tty4")
- (console-font-service "tty5")
- (console-font-service "tty6")
-
- (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)
- (urandom-seed-service)
- (guix-service)
- (nscd-service)
-
- ;; 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.
- (udev-service #:rules (list lvm2 fuse alsa-utils crda)))))
+ (list (login-service)
+
+ (service console-font-service-type
+ (map (lambda (tty)
+ (cons tty %default-console-font))
+ '("tty1" "tty2" "tty3" "tty4" "tty5" "tty6")))
+
+ (mingetty-service (mingetty-configuration
+ (tty "tty1")))
+ (mingetty-service (mingetty-configuration
+ (tty "tty2")))
+ (mingetty-service (mingetty-configuration
+ (tty "tty3")))
+ (mingetty-service (mingetty-configuration
+ (tty "tty4")))
+ (mingetty-service (mingetty-configuration
+ (tty "tty5")))
+ (mingetty-service (mingetty-configuration
+ (tty "tty6")))
+
+ (static-networking-service "lo" "127.0.0.1"
+ #:provision '(loopback))
+ (syslog-service)
+ (urandom-seed-service)
+ (guix-service)
+ (nscd-service)
+
+ ;; 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.
+ (udev-service #:rules (list lvm2 fuse alsa-utils crda))))
;;; base.scm ends here