Merge branch 'master' into core-updates

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