[bug#57721] [PATCH 4/4] gnu: base: Add greetd-wlgreet-sway-session.

["\( via Guix-patches" via <guix-patches@gnu.org>]

* gnu/services/base.scm (greetd-wlgreet-session): New data type.
(greetd-wlgreet-sway-session): Likewise.
* doc/guix.texi ("Base Services")[greetd-service-type]: Document
  them.
---
 doc/guix.texi         |  76 ++++++++++++++++++++++++++
 gnu/services/base.scm | 122 ++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 198 insertions(+)

diff --git a/doc/guix.texi b/doc/guix.texi
index c21235f28d..cf66014d8e 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -106,6 +106,7 @@ Copyright @copyright{} 2022 Philip M@sup{c}Grath@*
 Copyright @copyright{} 2022 Karl Hallsby@*
 Copyright @copyright{} 2022 Justin Veilleux@*
 Copyright @copyright{} 2022 Reily Siegel@*
+Copyright @copyright{} 2022 (@*
 
 Permission is granted to copy, distribute and/or modify this document
 under the terms of the GNU Free Documentation License, Version 1.3 or
@@ -18633,6 +18634,81 @@ are set right after mentioned variables, so that they can be overriden.
 @end table
 @end deftp
 
+@deftp {Data Type} greetd-wlgreet-session
+Generic configuration record for the wlgreet greetd greeter.
+
+@table @asis
+@item @code{wlgreet} (default: @code{wlgreet})
+The package with the @command{/bin/wlgreet} command.
+
+@item @code{command} (default: @code{(file-append sway "/bin/sway")})
+Command to be started by @command{/bin/wlgreet} on successful login.
+
+@item @code{command-args} (default: @code{'()})
+Command arguments to pass to command.
+
+@item @code{output-mode} (default: @code{"all"})
+Option to use for @code{outputMode} in the TOML configuration file.
+
+@item @code{scale} (default: @code{1})
+Option to use for @code{scale} in the TOML configuration file.
+
+@item @code{background} (default: @code{(list 0 0 0 0.9)})
+RGBA list to use as the background colour of the login prompt.
+
+@item @code{headline} (default: @code{(list 1 1 1 1)})
+RGBA list to use as the headline colour of the UI popup.
+
+@item @code{prompt} (default: @code{(list 1 1 1 1)})
+RGBA list to use as the prompt colour of the UI popup.
+
+@item @code{prompt-error} (default: @code{(list 1 1 1 1)})
+RGBA list to use as the error colour of the UI popup.
+
+@item @code{border} (default: @code{(list 1 1 1 1)})
+RGBA list to use as the border colour of the UI popup.
+
+@item @code{extra-env} (default: @code{'()})
+Extra environment variables to set on login.
+
+@end table
+@end deftp
+
+@deftp {Data Type} greetd-wlgreet-sway-session
+Sway-specific configuration record for the wlgreet greetd greeter.
+
+@table
+@item @code{wlgreet-session} (default: @code{(greetd-wlgreet-session)})
+A @code{greetd-wlgreet-session} record for generic wlgreet configuration,
+on top of the Sway-specific @code{greetd-wlgreet-sway-session}.
+
+@item @code{sway} (default: @code{sway})
+The package providing the @command{/bin/sway} command.
+
+@item @code{sway-configuration} (default: #f)
+File-like object providing an additional Sway configuration file to be
+prepended to the mandatory part of the configuration.
+
+@end table
+
+Here is an example of a greetd configuration that uses wlgreet and Sway:
+
+@lisp
+  (greetd-configuration
+   ;; We need to give the greeter user these permissions, otherwise
+   ;; Sway will crash on launch.
+   (greeter-supplementary-groups (list "video" "input" "seat"))
+   (terminals
+    (list (greetd-terminal-configuration
+           (terminal-vt "1")
+           (terminal-switch #t)
+           (default-session-command
+            (greetd-wlgreet-sway-session
+             (sway-configuration
+              (local-file "sway-greetd.conf"))))))))
+@end lisp
+@end deftp
+
 @node Scheduled Job Execution
 @subsection Scheduled Job Execution
 
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 616bc42e69..5de4e0a51a 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -19,6 +19,7 @@
 ;;; Copyright © 2021 muradm <mail@muradm.net>
 ;;; Copyright © 2022 Guillaume Le Vaillant <glv@posteo.net>
 ;;; Copyright © 2022 Justin Veilleux <terramorpha@cock.li>
+;;; Copyright © 2022 ( <paren@disroot.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -66,6 +67,7 @@ (define-module (gnu services base)
   #:use-module ((gnu packages gnupg) #:select (guile-gcrypt))
   #:use-module (gnu packages linux)
   #:use-module (gnu packages terminals)
+  #:use-module ((gnu packages wm) #:select (sway))
   #:use-module ((gnu build file-systems)
                 #:select (mount-flags->bit-mask
                           swap-space->flags-bit-mask))
@@ -231,6 +233,8 @@ (define-module (gnu services base)
             greetd-configuration
             greetd-terminal-configuration
             greetd-agreety-session
+            greetd-wlgreet-session
+            greetd-wlgreet-sway-session
 
             %base-services))
 
@@ -2869,6 +2873,122 @@ (define (make-greetd-agreety-session-command config command)
      "agreety-command"
      #~(execl #$agreety #$agreety "-c" #$command))))
 
+(define-record-type* <greetd-wlgreet-session>
+  greetd-wlgreet-session make-greetd-wlgreet-session
+  greetd-wlgreet-session?
+  (wlgreet greetd-wlgreet (default wlgreet))
+  (command greetd-wlgreet-command
+           (default (file-append sway "/bin/sway")))
+  (command-args greetd-wlgreet-command-args (default #~(list)))
+  (output-mode greetd-wlgreet-output-mode (default "all"))
+  (scale greetd-wlgreet-scale (default 1))
+  (background greetd-wlgreet-background (default (list 0 0 0 0.9)))
+  (headline greetd-wlgreet-headline (default (list 1 1 1 1)))
+  (prompt greetd-wlgreet-prompt (default (list 1 1 1 1)))
+  (prompt-error greetd-wlgreet-prompt-error (default (list 1 1 1 1)))
+  (border greetd-wlgreet-border (default (list 1 1 1 1)))
+  (extra-env greetd-wlgreet-extra-env (default #~(list))))
+
+(define (greetd-wlgreet-wayland-session-command session)
+  (program-file "wlgreet-session-command"
+    #~(let* ((username (getenv "USER"))
+             (useruid (number->string
+                       (passwd:uid (getpwuid username))))
+             (command #$(greetd-wlgreet-command session)))
+        (use-modules
+         (ice-9 format)
+         (ice-9 match))
+        (setenv "XDG_SESSION_TYPE" "wayland")
+        (setenv "XDG_RUNTIME_DIR"
+                (string-append "/run/user/" useruid))
+        (for-each (match-lambda
+                    ((var . val)
+                     (setenv var val)))
+                  #$(greetd-wlgreet-extra-env session))
+        (apply execl command command
+               #$(greetd-wlgreet-command-args session)))))
+
+(define (make-wlgreet-config-color section-name color)
+  (match color
+    ((red green blue opacity)
+     (string-append
+      "[" section-name "]\n"
+      "red = " (number->string red) "\n"
+      "green = " (number->string green) "\n"
+      "blue = " (number->string blue) "\n"
+      "opacity = " (number->string opacity) "\n"))))
+
+(define (make-wlgreet-configuration-file session)
+  (let ((command (greetd-wlgreet-wayland-session-command session))
+        (output-mode (greetd-wlgreet-output-mode session))
+        (scale (greetd-wlgreet-scale session))
+        (background (greetd-wlgreet-background session))
+        (headline (greetd-wlgreet-headline session))
+        (prompt (greetd-wlgreet-prompt session))
+        (prompt-error (greetd-wlgreet-prompt-error session))
+        (border (greetd-wlgreet-border session)))
+    (mixed-text-file "wlgreet.toml"
+      "command = \"" command "\"\n"
+      "outputMode = \"" output-mode "\"\n"
+      "scale = " (number->string scale) "\n"
+      (apply string-append
+             (map (match-lambda
+                    ((section-name . color)
+                     (make-wlgreet-config-color section-name color)))
+                  `(("background" . ,background)
+                    ("headline" . ,headline)
+                    ("prompt" . ,prompt)
+                    ("prompt-error" . ,prompt-error)
+                    ("border" . ,border)))))))
+
+(define-record-type* <greetd-wlgreet-sway-session>
+  greetd-wlgreet-sway-session make-greetd-wlgreet-sway-session
+  greetd-wlgreet-sway-session?
+  (wlgreet-session greetd-wlgreet-sway-session-wlgreet-session ;<greetd-wlgreet-session
+                   (default (greetd-wlgreet-session)))
+  (sway greetd-wlgreet-sway-session-sway (default sway)) ;<package>
+  (sway-configuration greetd-wlgreet-sway-session-sway-configuration ;file-like
+                      (default #f)))
+
+(define (make-wlgreet-sway-configuration-file session)
+  (let* ((wlgreet-session (greetd-wlgreet-sway-session-wlgreet-session session))
+         (wlgreet-config (make-wlgreet-configuration-file wlgreet-session))
+         (wlgreet (file-append (greetd-wlgreet wlgreet-session) "/bin/wlgreet"))
+         (sway-config (greetd-wlgreet-sway-session-sway-configuration session))
+         (swaymsg (file-append (greetd-wlgreet-sway-session-sway session)
+                               "/bin/swaymsg")))
+    (mixed-text-file "wlgreet-sway.conf"
+       (if sway-config
+           #~(string-append "include " #$sway-config "\n")
+           "")
+      "xwayland disable\n"
+      "exec \"" wlgreet " --config " wlgreet-config "; "
+      swaymsg " exit\"\n")))
+
+(define (greetd-wlgreet-sway-session-command session)
+  (program-file "wlgreet-sway-session-command"
+    #~(let* ((sway #$(file-append (greetd-wlgreet-sway-session-sway session)
+                                  "/bin/sway"))
+             (config #$(make-wlgreet-sway-configuration-file session))
+             (log-file (open-output-file
+                        (string-append "/tmp/sway-greeter."
+                                       (number->string (getpid))
+                                       ".log")))
+             (username (getenv "USER"))
+             (useruid (number->string (passwd:uid (getpwuid username)))))
+
+        ;; redirect stdout/err to log-file
+        (dup2 (fileno log-file) 1)
+        (dup2 1 2)
+
+        ;; XXX: If we start sway immediately, it won't find seatd for some
+        ;; reason...
+        (sleep 1)
+
+        (setenv "XDG_RUNTIME_DIR" (string-append "/run/user/" useruid))
+        (execl sway sway "-d" "-c" config))))
+
+
 (define (make-greetd-default-session-command config-or-command)
   (cond ((greetd-agreety-session? config-or-command)
          (cond ((greetd-agreety-xdg-env? config-or-command)
@@ -2879,6 +2999,8 @@ (define (make-greetd-default-session-command config-or-command)
                 (make-greetd-agreety-session-command
                  config-or-command
                  (greetd-agreety-tty-session-command config-or-command)))))
+        ((greetd-wlgreet-sway-session? config-or-command)
+         (greetd-wlgreet-sway-session-command config-or-command))
         (#t config-or-command)))
 
 (define-record-type* <greetd-terminal-configuration>
-- 
2.37.3