service modules: rework desktop base not to include gdm

2 files changed, 202 insertions, 151 deletions

diff --git a/px/services/base.scm b/px/services/base.scm
index 91a966e..f007e43 100644
--- a/px/services/base.scm
+++ b/px/services/base.scm
@@ -28,23 +28,19 @@
   #:use-module (px services device)
   #:use-module (px services security-token)
   #:use-module (guix gexp)
+  #:use-module (guix utils)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
   #:export (%px-core-services
 
             ;; for custom desktops (for ex. xfce)
             ;; without lxqt
-            %px-desktop-services-base
+            ; %px-desktop-services-base
             
             %px-desktop-services
             %px-desktop-ee-services
-
-            ;; for custom servers (for ex. docker)
-            ;; without nftables and dh
-            %px-server-services-base
             
             %px-server-services
-            ; %px-server-iptables-services
             %px-server-ee-services
 
             %px-core-arm-services
@@ -54,139 +50,34 @@
   #:re-export (px-desktop-service-type))
 
 ;;;
-;;; Utilities
-;;;
-
-(define (make-firewall-rules open-ports)
-
-  (define (make-port-rules open-ports status)
-    "Generate list of strings each is a port/service rule for nftables"
-    (reduce-right append '()
-                  (map (match-lambda
-                         ((protocol ports ...)
-                          (map (lambda (port)
-                                 (string-append "    " protocol " dport " port " " status))
-                               ports)))
-                       open-ports)))
-
-  (let ((port-rules (make-port-rules open-ports "accept")))
-    (plain-file "nftables"
-                (string-append "#PantherX firewall rules\n"
-                               "table inet filter {\n"
-                               "  chain input {\n"
-                               "    type filter hook input priority 0; policy drop;\n"
-                               "    # early drop of invalid connections\n"
-                               "    ct state invalid drop\n"
-                               "    # allow established/related connections\n"
-                               "    ct state { established, related } accept\n"
-                               "    # allow from loopback\n"
-                               "    iifname lo accept\n"
-                               "    # allow icmp\n"
-                               "    ip protocol icmp accept\n"
-                               "    ip6 nexthdr icmpv6 accept\n"
-                               (string-join port-rules "\n" 'suffix)
-                               "    # reject everything else\n"
-                               "    reject with icmpx type port-unreachable\n"
-                               "  }\n"
-                               "  chain forward {\n"
-                               "    type filter hook forward priority 0; policy drop;\n"
-                               "  }\n"
-                               "  chain output {\n"
-                               "    type filter hook output priority 0; policy accept;\n"
-                               "  }\n"
-                               "}\n"))))
-
-;;;
 ;;;
 ;;; CORE
+;;; px-core-os services
 ;;;
 
 (define %px-core-services
   (append
-   ;; list of services that only required to be available in px-core-os,
-   ;;  since they are available by default in upstream's %desktop-services
    (list (service dhcp-client-service-type)
          (service ntp-service-type))
    %base-services))
 
 ;;;
+;;;
 ;;; DESKTOP
+;;; px-desktop-os services
+;;; px-new-desktop services
 ;;;
 
-(define %px-desktop-services-base
-  (append (list
-           ;; Various udev rules incl. FIDO support
-           (simple-service 'custom-udev-rules
-                           udev-service-type
-                           (list libu2f-host))
-
-           (ledger-wallet-service)
-           (nitro-key-service)
-
-           ;; Power savings
-           (service tlp-service-type)
-
-           ;; Bluetooth service
-           ;; (bluetooth-service #:auto-enable? #t)
-           (service bluetooth-service-type
-                    (bluetooth-configuration
-                     (auto-enable? #t)))
-
-           ;; Prevent overheating
-           ;; TLP does not conflict with thermald.
-           (service thermald-service-type)
-
-           ; Display manager
-           (service sddm-service-type
-                    (sddm-configuration
-                     (minimum-uid 1000)
-                     (theme "px-sddm-theme")))
-
-           ;; Printing
-           (service cups-service-type
-                    (cups-configuration
-                     (web-interface? #t)
-                     (browsing? #t)
-                     (default-paper-size "a4")))
-
-           ;; Keychain
-           (service gnome-keyring-service-type
-                    (gnome-keyring-configuration
-                     (pam-services '(("passwd" . passwd)
-                                     ("sddm" . login)))))
-
-           ;; SSH is enabled by default but only with SSH key
-           (service openssh-service-type
-                    (openssh-configuration
-                     (permit-root-login 'prohibit-password)))
-
-           ;; Firewall
-           (service nftables-service-type
-                    (nftables-configuration
-                     (ruleset (make-firewall-rules '()))))
-
-           ;; Screensaver
-           (service screen-locker-service-type
-                    (screen-locker-configuration
-                      (name "xlock")
-                      (program (file-append xlockmore "/bin/xlock")))))
-
-          (modify-services %desktop-services
-                           ;; GDM is default on upstream, on x86_64
-                           (delete gdm-service-type)
-                           (delete screen-locker-service-type)
-                           (dbus-root-service-type config => (dbus-configuration (inherit config)
-                                                              (services (list blueman))))
-                           (network-manager-service-type config =>
-                                                         (network-manager-configuration
-                                                          (inherit config)
-                                                          (vpn-plugins (list network-manager-openvpn
-                                                                             network-manager-openconnect)))))))
-
 (define %px-desktop-services
   (append
          %px-desktop-services-base))
 
+;;;
+;;;
+;;; ENTERPRISE
+;;; px-desktop-ee-o services
+;;;
+
 (define %px-desktop-ee-services
   (append (list (service px-device-identity-service-type)
                 (service px-user-identity-service-type)
@@ -196,42 +87,28 @@
 
 ;;;
 ;;; SERVER
+;;; px-server-os services
+;;; px-server-ee-os services
 ;;;
 
-(define %px-server-services-base
+(define %px-server-services
   (append (list
-           ;; OpenSSH is enabled by default but only with SSH key
-           (service openssh-service-type
+            ;; OpenSSH is enabled by default but only with SSH key
+            (service openssh-service-type
                     (openssh-configuration
                      (permit-root-login 'prohibit-password)))
 
-           ;; Time service
-           (service ntp-service-type))
-
+            ;; Time service
+            (service ntp-service-type)
+            ;; Firewall
+            (service nftables-service-type)
+            ;; DHCP
+            (service dhcp-client-service-type))
           %base-services))
 
-(define %px-server-services
-  (append (list 
-                ;; Firewall
-                (service nftables-service-type)
-                ;; DHCP
-                (service dhcp-client-service-type))
-          %px-server-services-base))
-
-; (define %px-server-iptables-services
-;   (append (list 
-;                 ;; Firewall
-;                 ;; nftables doesn't work well with Docker
-;                 (service iptables-service-type))
-;           %px-server-services-base))
-
 (define %px-server-ee-services
-  (append (list (service px-device-identity-service-type)
-                ;; Firewall
-                (service nftables-service-type)
-                ;; DHCP
-                (service dhcp-client-service-type))
-          %px-server-services-base))
+  (append (list (service px-device-identity-service-type))
+          %px-server-services))
 
 ;;;
 ;;; ARM-SPECIFIC
@@ -289,5 +166,4 @@
                    (lxqt lxqt-modified)
                    (default-packages '()))))
    (modify-services %desktop-services
-                    (delete gdm-service-type)
                     (delete network-manager-service-type))))
\ No newline at end of file
diff --git a/px/services/desktop.scm b/px/services/desktop.scm
index 2ce403d..73ebdfd 100644
--- a/px/services/desktop.scm
+++ b/px/services/desktop.scm
@@ -9,6 +9,8 @@
   #:use-module (gnu packages base)
   #:use-module (gnu packages linux)
   #:use-module (gnu packages xdisorg)
+  #:use-module (gnu packages libusb)
+  #:use-module (gnu packages nfs)
   #:use-module (gnu services)
   #:use-module (gnu services avahi)
   #:use-module (gnu services base)
@@ -17,11 +19,14 @@
   #:use-module (gnu services desktop)
   #:use-module (gnu packages gnome)
   #:use-module (gnu packages lxqt)
+  #:use-module (gnu packages security-token)
   #:use-module (gnu services networking)
   #:use-module (gnu services shepherd)
   #:use-module (gnu services sddm)
   #:use-module (gnu services ssh)
   #:use-module (gnu services xorg)
+  #:use-module (gnu services sound)
+  #:use-module (gnu services pm)
   #:use-module (gnu system)
   #:use-module (gnu system setuid)
   #:use-module (guix build utils)
@@ -29,7 +34,9 @@
   #:use-module (guix packages)
   #:use-module (guix records)
   #:use-module (px packages desktop)
+  #:use-module (px services security-token)
   #:use-module (srfi srfi-1)
+  #:use-module (guix utils)
   #:use-module (ice-9 match)
   #:export (px-desktop-configuration
             px-desktop-configuration?
@@ -38,7 +45,9 @@
             polkit-network-manager-service
             polkit-elogind-service
 
-            create-swap-space-service))
+            create-swap-space-service
+            
+            %px-desktop-services-base))
 
 ;;
 ;; PantherX desktop service type
@@ -121,4 +130,170 @@ rules."
 ")))))
 
 (define polkit-elogind-service
-  (simple-service 'polkit-login polkit-service-type (list polkit-loginctl)))
\ No newline at end of file
+  (simple-service 'polkit-login polkit-service-type (list polkit-loginctl)))
+
+(define (make-firewall-rules open-ports)
+
+  (define (make-port-rules open-ports status)
+    "Generate list of strings each is a port/service rule for nftables"
+    (reduce-right append '()
+                  (map (match-lambda
+                         ((protocol ports ...)
+                          (map (lambda (port)
+                                 (string-append "    " protocol " dport " port " " status))
+                               ports)))
+                       open-ports)))
+
+  (let ((port-rules (make-port-rules open-ports "accept")))
+    (plain-file "nftables"
+                (string-append "#PantherX firewall rules\n"
+                               "table inet filter {\n"
+                               "  chain input {\n"
+                               "    type filter hook input priority 0; policy drop;\n"
+                               "    # early drop of invalid connections\n"
+                               "    ct state invalid drop\n"
+                               "    # allow established/related connections\n"
+                               "    ct state { established, related } accept\n"
+                               "    # allow from loopback\n"
+                               "    iifname lo accept\n"
+                               "    # allow icmp\n"
+                               "    ip protocol icmp accept\n"
+                               "    ip6 nexthdr icmpv6 accept\n"
+                               (string-join port-rules "\n" 'suffix)
+                               "    # reject everything else\n"
+                               "    reject with icmpx type port-unreachable\n"
+                               "  }\n"
+                               "  chain forward {\n"
+                               "    type filter hook forward priority 0; policy drop;\n"
+                               "  }\n"
+                               "  chain output {\n"
+                               "    type filter hook output priority 0; policy accept;\n"
+                               "  }\n"
+                               "}\n"))))
+
+
+(define* (desktop-services-for-system #:optional
+                                      (system (or (%current-target-system)
+                                                  (%current-system))))
+  ;; List of services typically useful for a "desktop" use case.
+
+  ;; Since GDM depends on Rust (gdm -> gnome-shell -> gjs -> mozjs -> rust)
+  ;; and Rust is currently unavailable on non-x86_64 platforms, default to
+  ;; SDDM there (FIXME).
+  (cons*  (service sddm-service-type)
+
+          ;; Screen lockers are a pretty useful thing and these are small.
+          (service screen-locker-service-type
+            (screen-locker-configuration
+              (name "xlock")
+              (program (file-append xlockmore "/bin/xlock"))))
+
+          ;; Add udev rules for MTP devices so that non-root users can access
+          ;; them.
+          (simple-service 'mtp udev-service-type (list libmtp))
+          ;; Add udev rules for scanners.
+          (service sane-service-type)
+          ;; Add polkit rules, so that non-root users in the wheel group can
+          ;; perform administrative tasks (similar to "sudo").
+          polkit-wheel-service
+
+          ;; Allow desktop users to also mount NTFS and NFS file systems
+          ;; without root.
+          (simple-service 'mount-setuid-helpers setuid-program-service-type
+                          (map (lambda (program)
+                                  (setuid-program
+                                  (program program)))
+                                (list (file-append nfs-utils "/sbin/mount.nfs")
+                                (file-append ntfs-3g "/sbin/mount.ntfs-3g"))))
+
+          ;; This is a volatile read-write file system mounted at /var/lib/gdm,
+          ;; to avoid GDM stale cache and permission issues.
+          gdm-file-system-service
+
+          ;; The global fontconfig cache directory can sometimes contain
+          ;; stale entries, possibly referencing fonts that have been GC'd,
+          ;; so mount it read-only.
+          fontconfig-file-system-service
+
+          ;; NetworkManager and its applet.
+          (service network-manager-service-type)
+          (service wpa-supplicant-service-type)    ;needed by NetworkManager
+          (simple-service 'network-manager-applet
+                          profile-service-type
+                          (list network-manager-applet))
+          (service modem-manager-service-type)
+          (service usb-modeswitch-service-type)
+
+          ;; The D-Bus clique.
+          (service avahi-service-type)
+          (service udisks-service-type)
+          (service upower-service-type)
+          (service accountsservice-service-type)
+          (service cups-pk-helper-service-type)
+          (service colord-service-type)
+          (service geoclue-service-type)
+          (service polkit-service-type)
+          (service elogind-service-type)
+          (service dbus-root-service-type)
+
+          (service ntp-service-type)
+
+          (service x11-socket-directory-service-type)
+
+          (service pulseaudio-service-type)
+          (service alsa-service-type)
+
+          ;; PantherX Specific
+          (simple-service 'custom-udev-rules
+                      udev-service-type
+                      (list libu2f-host))
+
+          (ledger-wallet-service)
+          (nitro-key-service)
+
+          ;; Power savings
+          (service tlp-service-type)
+
+          ;; Bluetooth service
+          ;; (bluetooth-service #:auto-enable? #t)
+          (service bluetooth-service-type
+                  (bluetooth-configuration
+                    (auto-enable? #t)))
+
+          ;; Prevent overheating
+          ;; TLP does not conflict with thermald.
+          (service thermald-service-type)
+
+          ; Display manager
+          (service sddm-service-type
+                  (sddm-configuration
+                    (minimum-uid 1000)
+                    (theme "px-sddm-theme")))
+
+          ;; Printing
+          (service cups-service-type
+                  (cups-configuration
+                    (web-interface? #t)
+                    (browsing? #t)
+                    (default-paper-size "a4")))
+
+          ;; Keychain
+          (service gnome-keyring-service-type
+                  (gnome-keyring-configuration
+                    (pam-services '(("passwd" . passwd)
+                                    ("sddm" . login)))))
+
+          ;; SSH is enabled by default but only with SSH key
+          (service openssh-service-type
+                  (openssh-configuration
+                    (permit-root-login 'prohibit-password)))
+
+          ;; Firewall
+          (service nftables-service-type
+                  (nftables-configuration
+                    (ruleset (make-firewall-rules '()))))
+
+         %base-services))
+
+(define-syntax %px-desktop-services-base
+  (identifier-syntax (desktop-services-for-system)))
\ No newline at end of file