08/08: gnu: Add draft of gdm service.

[Andy Wingo]

wingo pushed a commit to branch master
in repository guix.

commit 6e99c01b4d3ae6dfa467d83604484707f07f8e86
Author: Andy Wingo <address@hidden>
Date:   Tue Aug 22 18:41:19 2017 +0200

    gnu: Add draft of gdm service.
    
    * gnu/services/xorg.scm (%gdm-accounts, <gdm-configuration>)
    (gdm-etc-service, gdm-pam-service, gdm-shepherd-service, 
gdm-service-programs)
    (gdm-service-type, gdm-service): New public variables.  Not yet working.
---
 gnu/services/xorg.scm | 147 +++++++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 146 insertions(+), 1 deletion(-)

diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm
index cde6c4d..5a8ee6c 100644
--- a/gnu/services/xorg.scm
+++ b/gnu/services/xorg.scm
@@ -23,14 +23,17 @@
   #:use-module (gnu services)
   #:use-module (gnu services shepherd)
   #:use-module (gnu system pam)
+  #:use-module (gnu services dbus)
   #:use-module ((gnu packages base) #:select (canonical-package))
   #:use-module (gnu packages guile)
   #:use-module (gnu packages xorg)
   #:use-module (gnu packages gl)
   #:use-module (gnu packages display-managers)
   #:use-module (gnu packages gnustep)
+  #:use-module (gnu packages gnome)
   #:use-module (gnu packages admin)
   #:use-module (gnu packages bash)
+  #:use-module (gnu system shadow)
   #:use-module (guix gexp)
   #:use-module (guix store)
   #:use-module (guix packages)
@@ -55,7 +58,11 @@
             screen-locker
             screen-locker?
             screen-locker-service-type
-            screen-locker-service))
+            screen-locker-service
+
+            gdm-configuration
+            gdm-service-type
+            gdm-service))
 
 ;;; Commentary:
 ;;;
@@ -476,4 +483,142 @@ makes the good ol' XlockMore usable."
                           (file-append package "/bin/" program)
                           allow-empty-passwords?)))
 
+(define %gdm-accounts
+  (list (user-group (name "gdm") (system? #t))
+        (user-account
+         (name "gdm")
+         (group "gdm")
+         (system? #t)
+         (comment "GNOME Display Manager user")
+         (home-directory "/var/lib/gdm")
+         (shell (file-append shadow "/sbin/nologin")))))
+
+(define-record-type* <gdm-configuration>
+  gdm-configuration make-gdm-configuration
+  gdm-configuration?
+  (gdm gdm-configuration-gdm (default gdm))
+  (allow-empty-passwords? gdm-configuration-allow-empty-passwords? (default 
#t))
+  (allow-root? gdm-configuration-allow-root? (default #t))
+  (auto-login? gdm-configuration-auto-login? (default #f))
+  (default-user gdm-configuration-default-user (default #f))
+  (x-server gdm-configuration-x-server))
+
+(define (gdm-etc-service config)
+  (define gdm-configuration-file
+    (mixed-text-file "gdm-custom.conf"
+                     "[daemon]\n"
+                     "#User=gdm\n"
+                     "#Group=gdm\n"
+                     (if (gdm-configuration-auto-login? config)
+                         (string-append
+                          "AutomaticLoginEnable=true\n"
+                          "AutomaticLogin="
+                          (or (gdm-configuration-default-user config)
+                              (error "missing default user for auto-login"))
+                          "\n")
+                         (string-append
+                          "AutomaticLoginEnable=false\n"
+                          "#AutomaticLogin=\n"))
+                     "#TimedLoginEnable=false\n"
+                     "#TimedLogin=\n"
+                     "#TimedLoginDelay=0\n"
+                     "#InitialSetupEnable=true\n"
+                     ;; Enable me once X is working.
+                     "WaylandEnable=false\n"
+                     "\n"
+                     "[debug]\n"
+                     "Enable=true\n"
+                     "\n"
+                     "[security]\n"
+                     "#DisallowTCP=true\n"
+                     "#AllowRemoteAutoLogin=false\n"))
+  `(("gdm" ,(file-union
+             "gdm"
+             `(("custom.conf" ,gdm-configuration-file))))))
+
+(define (gdm-pam-service config)
+  "Return a PAM service for @command{gdm}."
+  (list
+   (pam-service
+    (inherit (unix-pam-service "gdm-autologin"))
+    (auth (list (pam-entry
+                 (control "[success=ok default=1]")
+                 (module (file-append (gdm-configuration-gdm config)
+                                      "/lib/security/pam_gdm.so")))
+                (pam-entry
+                 (control "sufficient")
+                 (module "pam_permit.so")))))
+   (pam-service
+    (inherit (unix-pam-service "gdm-launch-environment"))
+    (auth (list (pam-entry
+                 (control "required")
+                 (module "pam_permit.so")))))
+   (unix-pam-service
+    "gdm-password"
+    #:allow-empty-passwords? (gdm-configuration-allow-empty-passwords? config)
+    #:allow-root? (gdm-configuration-allow-root? config))))
+
+(define (gdm-shepherd-service config)
+  (list (shepherd-service
+         (documentation "Xorg display server (GDM)")
+         (provision '(xorg-server))
+         (requirement '(dbus-system user-processes host-name udev))
+         ;; While this service isn't working properly, turn off auto-start.
+         (auto-start? #f)
+         (start #~(lambda ()
+                    (fork+exec-command
+                     (list #$(file-append (gdm-configuration-gdm config)
+                                          "/bin/gdm"))
+                     #:environment-variables
+                     (list (string-append
+                            "GDM_X_SERVER="
+                            #$(gdm-configuration-x-server config))))))
+         (stop #~(make-kill-destructor))
+         (respawn? #t))))
+
+(define gdm-service-type
+  (service-type (name 'gdm)
+                (extensions
+                 (list (service-extension shepherd-root-service-type
+                                          gdm-shepherd-service)
+                       (service-extension account-service-type
+                                          (const %gdm-accounts))
+                       (service-extension pam-root-service-type
+                                          gdm-pam-service)
+                       (service-extension etc-service-type
+                                          gdm-etc-service)
+                       (service-extension dbus-root-service-type
+                                          (compose list 
gdm-configuration-gdm))))))
+
+;; This service isn't working yet; it gets as far as starting to run the
+;; greeter from gnome-shell but doesn't get any further.  It is here because
+;; it doesn't hurt anyone and perhaps it inspires someone to fix it :)
+(define* (gdm-service #:key (gdm gdm)
+                       (allow-empty-passwords? #t)
+                       (x-server (xorg-wrapper)))
+  "Return a service that spawns the GDM graphical login manager, which in turn
+starts the X display server with @var{X}, a command as returned by
address@hidden
+
address@hidden X session
+
+GDM automatically looks for session types described by the @file{.desktop}
+files in @file{/run/current-system/profile/share/xsessions} and allows users
+to choose a session from the log-in screen using @kbd{F1}.  Packages such as
address@hidden, @var{sawfish}, and @var{ratpoison} provide @file{.desktop} 
files;
+adding them to the system-wide set of packages automatically makes them
+available at the log-in screen.
+
+In addition, @file{~/.xsession} files are honored.  When available,
address@hidden/.xsession} must be an executable that starts a window manager
+and/or other X clients.
+
+When @var{allow-empty-passwords?} is true, allow logins with an empty
+password."
+  (service gdm-service-type
+           (gdm-configuration
+            (gdm gdm)
+            (allow-empty-passwords? allow-empty-passwords?)
+            (x-server x-server))))
+
 ;;; xorg.scm ends here