# greetd.scm -rw-r--r-- 3.9 KiB View raw
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
;;; GNU Guix --- Functional package management for GNU
;;;
;;; Copyright © 2022 ( <paren@disroot.org>
;;;
;;; This file is not part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guixrus services greetd)
  #:use-module (guix gexp)
  #:use-module (guix records)
  #:use-module (guix store)
  #:use-module (gnu packages admin)
  #:use-module (gnu packages wm)
  #:use-module (guixrus packages greetd)
  #:use-module (ice-9 match)
  #:export (greetd-wlgreet-session
            greetd-wlgreet-xdg-session-command))

(define-record-type* <greetd-wlgreet-session>
  greetd-wlgreet-session make-greetd-wlgreet-session
  greetd-wlgreet-session?
  (wlgreet greetd-wlgreet (default wlgreet))
  (config-file-name greetd-wlgreet-config-file-name (default "wlgreet.toml"))
  (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 '()))
  (xdg-env? greetd-wlgreet-xdg-env? (default #t)))

(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"))))

(define make-wlgreet-configuration-file
  (match-lambda
    (($ <greetd-wlgreet-session> _ config-file-name command command-args
        output-mode scale background headline prompt prompt-error border)
     (mixed-text-file config-file-name
       "command = \"" command " " (string-join command-args " ") "\"\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 (greetd-wlgreet-xdg-session-command session)
  (match session
    (($ <greetd-wlgreet-session> wlgreet config-file-name)
     (let ((wlgreet (file-append wlgreet "/bin/wlgreet"))
           (config (make-wlgreet-configuration-file session)))
       (program-file "wlgreet-xdg-session-command"
         #~(begin
             (use-modules (ice-9 match))
             (let* ((username (getenv "USER"))
                    (useruid (number->string
                              (passwd:uid (getpwuid username)))))
               (setenv "XDG_SESSION_TYPE" "wayland")
               (setenv "XDG_RUNTIME_DIR" (string-append "/run/user/" useruid)))
             (for-each (match-lambda ((name . val) (setenv name val)))
                       extra-env)
             (execl #$wlgreet #$wlgreet "--config" #$config)))))))