diff options
Diffstat (limited to 'gnu/services')
| -rw-r--r-- | gnu/services/base.scm | 240 | ||||
| -rw-r--r-- | gnu/services/messaging.scm | 15 | ||||
| -rw-r--r-- | gnu/services/ssh.scm | 8 |
3 files changed, 249 insertions, 14 deletions
diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 57601eab85..5298a11f63 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -3,7 +3,7 @@ ;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com> ;;; Copyright © 2015, 2016 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com> -;;; Copyright © 2016 Leo Famulari <leo@famulari.name> +;;; Copyright © 2016, 2017 Leo Famulari <leo@famulari.name> ;;; Copyright © 2016 David Craven <david@craven.ch> ;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net> ;;; @@ -38,6 +38,7 @@ #:select (canonical-package glibc)) #:use-module (gnu packages bash) #:use-module (gnu packages package-management) + #:use-module (gnu packages linux) #:use-module (gnu packages lsof) #:use-module (gnu packages terminals) #:use-module ((gnu build file-systems) @@ -74,6 +75,11 @@ login-service-type login-service + agetty-configuration + agetty-configuration? + agetty-service + agetty-service-type + mingetty-configuration mingetty-configuration? mingetty-service @@ -730,6 +736,222 @@ Return a service that sets up Unicode support in @var{tty} and loads the message of the day, among other things." (service login-service-type config)) +(define-record-type* <agetty-configuration> + agetty-configuration make-agetty-configuration + agetty-configuration? + (agetty agetty-configuration-agetty ;<package> + (default util-linux)) + (tty agetty-configuration-tty) ;string + (term agetty-term ;string | #f + (default #f)) + (baud-rate agetty-baud-rate ;string | #f + (default #f)) + (auto-login agetty-auto-login ;list of strings | #f + (default #f)) + (login-program agetty-login-program ;gexp + (default (file-append shadow "/bin/login"))) + (login-pause? agetty-login-pause? ;Boolean + (default #f)) + (eight-bits? agetty-eight-bits? ;Boolean + (default #f)) + (no-reset? agetty-no-reset? ;Boolean + (default #f)) + (remote? agetty-remote? ;Boolean + (default #f)) + (flow-control? agetty-flow-control? ;Boolean + (default #f)) + (host agetty-host ;string | #f + (default #f)) + (no-issue? agetty-no-issue? ;Boolean + (default #f)) + (init-string agetty-init-string ;string | #f + (default #f)) + (no-clear? agetty-no-clear? ;Boolean + (default #f)) + (local-line agetty-local-line ;always | never | auto + (default #f)) + (extract-baud? agetty-extract-baud? ;Boolean + (default #f)) + (skip-login? agetty-skip-login? ;Boolean + (default #f)) + (no-newline? agetty-no-newline? ;Boolean + (default #f)) + (login-options agetty-login-options ;string | #f + (default #f)) + (chroot agetty-chroot ;string | #f + (default #f)) + (hangup? agetty-hangup? ;Boolean + (default #f)) + (keep-baud? agetty-keep-baud? ;Boolean + (default #f)) + (timeout agetty-timeout ;integer | #f + (default #f)) + (detect-case? agetty-detect-case? ;Boolean + (default #f)) + (wait-cr? agetty-wait-cr? ;Boolean + (default #f)) + (no-hints? agetty-no-hints? ;Boolean + (default #f)) + (no-hostname? agetty-no hostname? ;Boolean + (default #f)) + (long-hostname? agetty-long-hostname? ;Boolean + (default #f)) + (erase-characters agetty-erase-characters ;string | #f + (default #f)) + (kill-characters agetty-kill-characters ;string | #f + (default #f)) + (chdir agetty-chdir ;string | #f + (default #f)) + (delay agetty-delay ;integer | #f + (default #f)) + (nice agetty-nice ;integer | #f + (default #f)) + ;; "Escape hatch" for passing arbitrary command-line arguments. + (extra-options agetty-extra-options ;list of strings + (default '())) +;;; XXX Unimplemented for now! +;;; (issue-file agetty-issue-file ;file-like +;;; (default #f)) + ) + +(define agetty-shepherd-service + (match-lambda + (($ <agetty-configuration> agetty tty term baud-rate auto-login + login-program login-pause? eight-bits? no-reset? remote? flow-control? + host no-issue? init-string no-clear? local-line extract-baud? + skip-login? no-newline? login-options chroot hangup? keep-baud? timeout + detect-case? wait-cr? no-hints? no-hostname? long-hostname? + erase-characters kill-characters chdir delay nice extra-options) + (list + (shepherd-service + (documentation "Run agetty on a 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 (see also + ;; mingetty-shepherd-service). + (requirement '(user-processes host-name udev)) + + (start #~(make-forkexec-constructor + (list #$(file-append util-linux "/sbin/agetty") + #$@extra-options + #$@(if eight-bits? + #~("--8bits") + #~()) + #$@(if no-reset? + #~("--noreset") + #~()) + #$@(if remote? + #~("--remote") + #~()) + #$@(if flow-control? + #~("--flow-control") + #~()) + #$@(if host + #~("--host" #$host) + #~()) + #$@(if no-issue? + #~("--noissue") + #~()) + #$@(if init-string + #~("--init-string" #$init-string) + #~()) + #$@(if no-clear? + #~("--noclear") + #~()) +;;; FIXME This doesn't work as expected. According to agetty(8), if this option +;;; is not passed, then the default is 'auto'. However, in my tests, when that +;;; option is selected, agetty never presents the login prompt, and the +;;; term-ttyS0 service respawns every few seconds. + #$@(if local-line + #~(#$(match local-line + ('auto "--local-line=auto") + ('always "--local-line=always") + ('never "-local-line=never"))) + #~()) + #$@(if extract-baud? + #~("--extract-baud") + #~()) + #$@(if skip-login? + #~("--skip-login") + #~()) + #$@(if no-newline? + #~("--nonewline") + #~()) + #$@(if login-options + #~("--login-options" #$login-options) + #~()) + #$@(if chroot + #~("--chroot" #$chroot) + #~()) + #$@(if hangup? + #~("--hangup") + #~()) + #$@(if keep-baud? + #~("--keep-baud") + #~()) + #$@(if timeout + #~("--timeout" #$(number->string timeout)) + #~()) + #$@(if detect-case? + #~("--detect-case") + #~()) + #$@(if wait-cr? + #~("--wait-cr") + #~()) + #$@(if no-hints? + #~("--nohints?") + #~()) + #$@(if no-hostname? + #~("--nohostname") + #~()) + #$@(if long-hostname? + #~("--long-hostname") + #~()) + #$@(if erase-characters + #~("--erase-chars" #$erase-characters) + #~()) + #$@(if kill-characters + #~("--kill-chars" #$kill-characters) + #~()) + #$@(if chdir + #~("--chdir" #$chdir) + #~()) + #$@(if delay + #~("--delay" #$(number->string delay)) + #~()) + #$@(if nice + #~("--nice" #$(number->string nice)) + #~()) + #$@(if auto-login + (list "--autologin" auto-login) + '()) + #$@(if login-program + #~("--login-program" #$login-program) + #~()) + #$@(if login-pause? + #~("--login-pause") + #~()) + #$tty + #$@(if baud-rate + #~(#$baud-rate) + #~()) + #$@(if term + #~(#$term) + #~())))) + (stop #~(make-kill-destructor))))))) + +(define agetty-service-type + (service-type (name 'agetty) + (extensions (list (service-extension shepherd-root-service-type + agetty-shepherd-service))))) + +(define* (agetty-service config) + "Return a service to run agetty according to @var{config}, which specifies +the tty to run, among other things." + (service agetty-service-type config)) + (define-record-type* <mingetty-configuration> mingetty-configuration make-mingetty-configuration mingetty-configuration? @@ -1114,7 +1336,11 @@ failed to register hydra.gnu.org public key: ~a~%" status)))))))) (log-file guix-configuration-log-file ;string (default "/var/log/guix-daemon.log")) (lsof guix-configuration-lsof ;<package> - (default lsof))) + (default lsof)) + (http-proxy guix-http-proxy ;string | #f + (default #f)) + (tmpdir guix-tmpdir ;string | #f + (default #f))) (define %default-guix-configuration (guix-configuration)) @@ -1125,7 +1351,7 @@ failed to register hydra.gnu.org public key: ~a~%" status)))))))) (($ <guix-configuration> guix build-group build-accounts authorize-key? keys use-substitutes? substitute-urls extra-options - log-file lsof) + log-file lsof http-proxy tmpdir) (list (shepherd-service (documentation "Run the Guix daemon.") (provision '(guix-daemon)) @@ -1142,7 +1368,13 @@ failed to register hydra.gnu.org public key: ~a~%" status)))))))) ;; Add 'lsof' (for the GC) to the daemon's $PATH. #:environment-variables - (list (string-append "PATH=" #$lsof "/bin")) + (list (string-append "PATH=" #$lsof "/bin") + #$@(if http-proxy + (list (string-append "http_proxy=" http-proxy)) + '()) + #$@(if tmpdir + (list (string-append "TMPDIR=" tmpdir)) + '())) #:log-file #$log-file)) (stop #~(make-kill-destructor))))))) diff --git a/gnu/services/messaging.scm b/gnu/services/messaging.scm index 9f59d6eac6..34723dc11c 100644 --- a/gnu/services/messaging.scm +++ b/gnu/services/messaging.scm @@ -49,8 +49,9 @@ ;;; ;;; Code: -(define (id ctx . parts) - (datum->syntax ctx (apply symbol-append (map syntax->datum parts)))) +(define-syntax-rule (id ctx parts ...) + "Assemble PARTS into a raw (unhygienic) identifier." + (datum->syntax ctx (symbol-append (syntax->datum parts) ...))) (define-syntax define-maybe (lambda (x) @@ -94,21 +95,21 @@ "" doc)) #'(doc ...) #'(target ...)))) #`(begin - (define common-fields + (define #,(id #'stem #'common-fields) '(#,@(filter-map (make-pred #f) #'(field ...) #'(target ...)))) - (define-configuration prosody-configuration + (define-configuration #,(id #'stem #'prosody-configuration) #,@(filter-map (make-pred 'global) #'((field (field-type def) doc) ...) #'(target ...))) - (define-configuration virtualhost-configuration + (define-configuration #,(id #'stem #'virtualhost-configuration) #,@(filter-map (make-pred 'virtualhost) #'((field (new-field-type new-def) new-doc) ...) #'(target ...))) - (define-configuration int-component-configuration + (define-configuration #,(id #'stem #'int-component-configuration) #,@(filter-map (make-pred 'int-component) #'((field (new-field-type new-def) new-doc) ...) #'(target ...))) - (define-configuration ext-component-configuration + (define-configuration #,(id #'stem #'ext-component-configuration) #,@(filter-map (make-pred 'ext-component) #'((field (new-field-type new-def) new-doc) ...) #'(target ...))))))))) diff --git a/gnu/services/ssh.scm b/gnu/services/ssh.scm index 58c35c9f5e..c1d42e70ce 100644 --- a/gnu/services/ssh.scm +++ b/gnu/services/ssh.scm @@ -38,7 +38,6 @@ openssh-configuration openssh-configuration? openssh-service-type - openssh-service dropbear-configuration dropbear-configuration? @@ -261,6 +260,8 @@ The other options should be self-descriptive." (define-record-type* <openssh-configuration> openssh-configuration make-openssh-configuration openssh-configuration? + (openssh openssh-configuration-openssh ;package + (default openssh)) (pid-file openssh-configuration-pid-file (default "/var/run/sshd.pid")) (port-number openssh-configuration-port-number ;integer @@ -298,7 +299,8 @@ The other options should be self-descriptive." (mkdir-p (dirname #$(openssh-configuration-pid-file config))) ;; Generate missing host keys. - (system* (string-append #$openssh "/bin/ssh-keygen") "-A"))) + (system* (string-append #$(openssh-configuration-openssh config) + "/bin/ssh-keygen") "-A"))) (define (openssh-config-file config) "Return the sshd configuration file corresponding to CONFIG." @@ -343,7 +345,7 @@ The other options should be self-descriptive." (openssh-configuration-pid-file config)) (define openssh-command - #~(list (string-append #$openssh "/sbin/sshd") + #~(list (string-append #$(openssh-configuration-openssh config) "/sbin/sshd") "-D" "-f" #$(openssh-config-file config))) (list (shepherd-service |