summaryrefslogtreecommitdiff
path: root/px/system/os.scm
diff options
context:
space:
mode:
Diffstat (limited to 'px/system/os.scm')
-rw-r--r--px/system/os.scm298
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)))
generated by cgit v1.2.3 (git 2.49.0) at 2025-07-05 08:38:49 +0000