rewrite: apply guix-reference formatting; cleanup some module imports

1 files changed, 154 insertions, 144 deletions

diff --git a/px/system/os.scm b/px/system/os.scm
index f397fbd..fec1984 100644
--- a/px/system/os.scm
+++ b/px/system/os.scm
@@ -19,7 +19,6 @@
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
   #:export (make-os
-
             os-template
             os-template-service
 
@@ -34,87 +33,82 @@
             ;; This is not used anywhere
             ;; %px-artwork-repository
             ;; %px-grub-theme
-
+            
             ;; %px-substitute-server-url
             ;; %px-substitute-server-key
-            apply-px-substitute-server
-            ))
+            apply-px-substitute-server))
 
 ;;;
 ;;; Templates
 ;;;
 
-(define-record-type* <os-template-service>
-  os-template-service make-os-template-service
+(define-record-type* <os-template-service> os-template-service
+                     make-os-template-service
   os-template-service?
-  (type   os-template-service-type)     ; type of modification required: 'add 'edit 'delete
-  (kind   os-template-service-kind)     ; service-kind that needs to be matched
-  (action os-template-service-action    ; action to be applied on service
+  (type os-template-service-type) ;type of modification required: 'add 'edit 'delete
+  (kind os-template-service-kind) ;service-kind that needs to be matched
+  (action os-template-service-action ;action to be applied on service
           (default #f)))
 
-(define-record-type* <os-template>
-  os-template make-os-template
+(define-record-type* <os-template> os-template make-os-template
   os-template?
-  (title     os-template-title)
-  (firmwares os-template-firmwares      ; list of firmwares to be installed
+  (title os-template-title)
+  (firmwares os-template-firmwares ;list of firmwares to be installed
              (default '()))
-  (packages  os-template-packages       ; list of <package> to be installed
-             (default '()))
-  (services  os-template-services       ; list of <os-template-service>
-             (default '())))
+  (packages os-template-packages ;list of <package> to be installed
+            (default '()))
+  (services os-template-services ;list of <os-template-service>
+            (default '())))
 
 (define (apply-template-firmwares initial-firmwares template-firmwares)
   (fold (lambda (firmware result)
-          (if (memq firmware result)
-              result
-              (cons firmware result)))
-        initial-firmwares
-        template-firmwares))
+          (if (memq firmware result) result
+              (cons firmware result))) initial-firmwares template-firmwares))
 
 (define (apply-template-package-imports initial-packages template-packages)
   (fold (lambda (pkg result)
-          (if (memq pkg result)
-              result
-              (cons pkg result)))
-        initial-packages
-        template-packages))
+          (if (memq pkg result) result
+              (cons pkg result))) initial-packages template-packages))
 
-(define (apply-template-service-modifications initial-services template-services)
+(define (apply-template-service-modifications initial-services
+                                              template-services)
   (fold (lambda (svc result)
           (match svc
             (($ <os-template-service> type kind action)
              (case type
-               ((add) (cons (if action
-                                (service kind action)
-                                (service kind))
-                            result))
-               ((edit) (modify-services result
-                                        (kind config => (action config))))
-               ((delete) (remove (lambda (s)
-                                   (eq? (service-kind s) kind))
-                                 result))
-               (else result)))))
-        initial-services
-        template-services))
+               ((add)
+                (cons (if action
+                          (service kind action)
+                          (service kind)) result))
+               ((edit)
+                (modify-services result
+                  (kind config =>
+                        (action config))))
+               ((delete)
+                (remove (lambda (s)
+                          (eq? (service-kind s) kind)) result))
+               (else result))))) initial-services template-services))
 
 (define (apply-templates os-configuration os-templates)
   (fold (lambda (template result)
-          (let ((target-firmwares (apply-template-firmwares
-                                   (operating-system-firmware os-configuration)
-                                   (os-template-firmwares template)))
-                (target-packages (apply-template-package-imports
-                                  (operating-system-packages result)
-                                  (os-template-packages template)))
-                (target-services (apply-template-service-modifications
-                                  (operating-system-user-services result)
-                                  (os-template-services template))))
+          (let ((target-firmwares (apply-template-firmwares (operating-system-firmware
+                                                             os-configuration)
+                                                            (os-template-firmwares
+                                                             template)))
+                (target-packages (apply-template-package-imports (operating-system-packages
+                                                                  result)
+                                                                 (os-template-packages
+                                                                  template)))
+                (target-services (apply-template-service-modifications (operating-system-user-services
+                                                                        result)
+                                                                       (os-template-services
+                                                                        template))))
             (operating-system
-             (inherit result)
-             (firmware target-firmwares)
-             (packages target-packages)
-             (services target-services))))
-        os-configuration
-        os-templates))
+              (inherit result)
+              (firmware target-firmwares)
+              (packages target-packages)
+              (services
+               target-services)))) os-configuration os-templates))
 
 ;;
 ;; Firewall customization
@@ -123,38 +117,48 @@
 (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 '()
+    (reduce-right append
+                  '()
                   (map (match-lambda
                          ((protocol ports ...)
                           (map (lambda (port)
-                                 (string-append "    " protocol " dport " port " " status))
-                               ports)))
-                       open-ports)))
+                                 (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"
+                (string-append "#PantherX firewall rules\n"
                  "table inet filter {\n"
                  "  chain input {\n"
-                 "    type filter hook input priority 0; policy drop;\n"
+                 "    type filter hook input priority 0; policy drop;
+"
                  "    # early drop of invalid connections\n"
                  "    ct state invalid drop\n"
-                 "    # allow established/related connections\n"
-                 "    ct state { established, related } accept\n"
+                 "    # allow established/related connections
+"
+                 "    ct state { established, related } accept
+"
                  "    # 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)
+                 (string-join port-rules "\n"
+                              'suffix)
                  "    # reject everything else\n"
-                 "    reject with icmpx type port-unreachable\n"
+                 "    reject with icmpx type port-unreachable
+"
                  "  }\n"
                  "  chain forward {\n"
-                 "    type filter hook forward priority 0; policy drop;\n"
+                 "    type filter hook forward priority 0; policy drop;
+"
                  "  }\n"
                  "  chain output {\n"
-                 "    type filter hook output priority 0; policy accept;\n"
+                 "    type filter hook output priority 0; policy accept;
+"
                  "  }\n"
                  "}\n"))))
 
@@ -165,27 +169,24 @@
 (define %px-artwork-repository
   (let ((commit "ecfd456e814a59e3b6743bcda83eab5d5c12ae99"))
     (origin
-     (method git-fetch)
-     (uri (git-reference
-           (url "https://git.pantherx.org/development/desktop/px-artwork.git")
-           (commit commit)))
-     (file-name (string-append "px-artwork-" (string-take commit 7)
-                               "-checkout"))
-     (sha256
-      (base32
-       "06i47c8qp239c9rgkcizk3jd8rld4qbx90s5gg1a1rw1x90p245z")))))
+      (method git-fetch)
+      (uri (git-reference (url
+                           "https://git.pantherx.org/development/desktop/px-artwork.git")
+                          (commit commit)))
+      (file-name (string-append "px-artwork-"
+                                (string-take commit 7) "-checkout"))
+      (sha256 (base32 "06i47c8qp239c9rgkcizk3jd8rld4qbx90s5gg1a1rw1x90p245z")))))
 
 (define %px-grub-theme
-  (grub-theme
-   (image (file-append %px-artwork-repository
-                       "/grub/PantherX-4-3.svg"))))
+  (grub-theme (image (file-append %px-artwork-repository
+                                  "/grub/PantherX-4-3.svg"))))
 
 (define %px-substitute-server-url
   "https://packages.pantherx.org")
 
 (define %px-substitute-server-key
   (plain-file "packages.pantherx.org.pub"
-              "(public-key 
+   "(public-key 
  (ecc 
   (curve Ed25519)
   (q #E8322D13EA02C09F06CB70FDA2ABBFD5E463F2AA34C18C692F5E25858F4E315D#)
@@ -199,50 +200,51 @@
     (case (bootloader-name bootloader)
       ((grub grub-efi)
        (bootloader-configuration
-        (inherit bootloader-config)
-        (theme %px-grub-theme)))
+         (inherit bootloader-config)
+         (theme %px-grub-theme)))
       (else bootloader-config))))
 
 (define (prepare-packages config default-packages)
   "Check if custom packages provided in system configuration file or not.
 return @code{default-packages} if there was no modifications applied."
   (let ((package-list (operating-system-packages config)))
-    (if (eq? package-list %base-packages)
-        default-packages
-        package-list)))
+    (if (eq? package-list %base-packages) default-packages package-list)))
 
 (define (prepare-services config default-services)
   "Check if custom services provided in system configuration file or not.
 return @code{default-services} if there is no modification applied."
   (let ((service-list (operating-system-user-services config)))
-    (if (eq? service-list %base-services)
-        default-services
-        service-list)))
+    (if (eq? service-list %base-services) default-services service-list)))
 
 (define (prepare-swap-devices config default-value)
   "Check if custom definition provided for swap-devices or not.
 return @code{defaule-value} if there is no modification applied."
   (let ((devices (operating-system-swap-devices config)))
-    (if (eq? devices '())
-        default-value
-        devices)))
+    (if (eq? devices
+             '()) default-value devices)))
 
 (define (prepare-kernel config kernel)
   (case kernel
-    ((libre) linux-libre)
-    ((nonlibre) linux)
+    ((libre)
+     linux-libre)
+    ((nonlibre)
+     linux)
     (else (operating-system-kernel config))))
 
 (define (prepare-initrd config kernel)
   (case kernel
-    ((libre) base-initrd)
-    ((nonlibre) microcode-initrd)
+    ((libre)
+     base-initrd)
+    ((nonlibre)
+     microcode-initrd)
     (else (operating-system-initrd config))))
 
 (define (prepare-firmwares config kernel)
   (case kernel
-    ((libre) %base-firmware)
-    ((nonlibre) (list linux-firmware))
+    ((libre)
+     %base-firmware)
+    ((nonlibre)
+     (list linux-firmware))
     (else (operating-system-firmware config))))
 
 ;;
@@ -252,15 +254,16 @@ return @code{defaule-value} if there is no modification applied."
 (define (apply-px-substitute-server guix-config)
   (let ((existing-urls (guix-configuration-substitute-urls guix-config))
         (existing-keys (guix-configuration-authorized-keys guix-config)))
-    (guix-configuration
-     (inherit guix-config)
-     (substitute-urls (append (list %px-substitute-server-url)
-                      existing-urls))
-     (authorized-keys (append (list %px-substitute-server-key)
-                      existing-keys)))))
-
-(define* (make-os config #:key
-                  (kernel 'libre)
+    (guix-configuration (inherit guix-config)
+                        (substitute-urls (append (list
+                                                  %px-substitute-server-url)
+                                                 existing-urls))
+                        (authorized-keys (append (list
+                                                  %px-substitute-server-key)
+                                                 existing-keys)))))
+
+(define* (make-os config
+                  #:key (kernel 'libre)
                   (open-ports #f)
                   (authorized-keys '())
                   (templates '())
@@ -270,50 +273,57 @@ return @code{defaule-value} if there is no modification applied."
 packages and services"
 
   (define (apply-firewall-rules config)
-    (nftables-configuration
-     (inherit config)
-     (ruleset (if open-ports
-                  (make-firewall-rules open-ports)
-                  (nftables-configuration-ruleset config)))))
+    (nftables-configuration (inherit config)
+                            (ruleset (if open-ports
+                                         (make-firewall-rules open-ports)
+                                         (nftables-configuration-ruleset
+                                          config)))))
+
   (define (apply-authorized-keys config)
     (if (> (length authorized-keys) 0)
-        (openssh-configuration
-         (inherit config)
-         (authorized-keys authorized-keys))
-        config))
+        (openssh-configuration (inherit config)
+                               (authorized-keys authorized-keys)) config))
+
   (define (apply-swap-changes config)
     (let ((devices (operating-system-swap-devices config)))
-      (if (eq? devices '())
-          (list (swap-space (target "/swapfile")))
-          devices)))
+      (if (eq? devices
+               '())
+          (list (swap-space
+                  (target "/swapfile"))) devices)))
+
   (let ((target-kernel (prepare-kernel config kernel))
         (target-initrd (prepare-initrd config kernel))
         (target-firmwares (prepare-firmwares config kernel))
         (target-bootloader (adjust-bootloader-theme config))
         (target-packages (prepare-packages config default-packages))
         (target-services (prepare-services config default-services)))
-    (apply-templates
-     (operating-system
-      (inherit config)
-      (bootloader target-bootloader)
-      (kernel target-kernel)
-      (initrd target-initrd)
-      (firmware target-firmwares)
-      (swap-devices (apply-swap-changes config))
-      
-      (packages target-packages)
-      (services (fold (lambda (svc result)
-                        (let ((type (service-kind svc))
-                              (value (service-value svc)))
-                          (cond
-                            ((eq? type guix-service-type)
-                             (cons (service guix-service-type (apply-px-substitute-server value)) result))
-                            ((eq? type nftables-service-type)
-                             (cons (service nftables-service-type (apply-firewall-rules value)) result))
-                            ((eq? type openssh-service-type)
-                             (cons (service openssh-service-type (apply-authorized-keys value)) result))
-                            (else (cons svc result)))))
-                      '()
-                      target-services))
-      (name-service-switch %mdns-host-lookup-nss))
-     templates)))
+    
+    (apply-templates (operating-system
+                       (inherit config)
+                       (bootloader target-bootloader)
+                       (kernel target-kernel)
+                       (initrd target-initrd)
+                       (firmware target-firmwares)
+                       (swap-devices (apply-swap-changes config))
+
+                       (packages target-packages)
+                       (services
+                        (fold (lambda (svc result)
+                                (let ((type (service-kind svc))
+                                      (value (service-value svc)))
+                                  (cond
+                                    ((eq? type guix-service-type)
+                                     (cons (service guix-service-type
+                                                    (apply-px-substitute-server
+                                                     value)) result))
+                                    ((eq? type nftables-service-type)
+                                     (cons (service nftables-service-type
+                                                    (apply-firewall-rules
+                                                     value)) result))
+                                    ((eq? type openssh-service-type)
+                                     (cons (service openssh-service-type
+                                                    (apply-authorized-keys
+                                                     value)) result))
+                                    (else (cons svc result)))))
+                              '() target-services))
+                       (name-service-switch %mdns-host-lookup-nss)) templates)))