initial commit

1 files changed, 319 insertions, 0 deletions

diff --git a/px/system/os.scm b/px/system/os.scm
new file mode 100644
index 0000000..cdff7e8
--- /dev/null
+++ b/px/system/os.scm
@@ -0,0 +1,319 @@
+(define-module (px system os)
+  #:use-module (gnu bootloader)
+  #:use-module (gnu bootloader grub)
+  #:use-module (gnu packages linux)
+  #:use-module (gnu services)
+  #:use-module (gnu services base)
+  #:use-module (gnu services networking)
+  #:use-module (gnu services ssh)
+  #:use-module (gnu system)
+  #:use-module (gnu system file-systems)
+  #:use-module (gnu system linux-initrd)
+  #:use-module (gnu system nss)
+  #:use-module (nongnu packages linux)
+  #:use-module (nongnu system linux-initrd)
+  #:use-module (guix gexp)
+  #:use-module (guix git-download)
+  #:use-module (guix packages)
+  #:use-module (guix records)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:export (make-os
+
+            os-template
+            os-template-service
+
+            ;; used in px system config
+            prepare-packages
+            prepare-services
+            prepare-swap-devices
+
+            ;; used in ee repo
+            adjust-bootloader-theme
+
+            ;; This is not used anywhere
+            ;; %px-artwork-repository
+            ;; %px-grub-theme
+
+            ;; %px-substitute-server-url
+            ;; %px-substitute-server-key
+            ;; apply-px-substitute-server
+            ))
+
+;;;
+;;; Templates
+;;;
+
+(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
+          (default #f)))
+
+(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
+             (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))
+
+(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))
+
+(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))
+
+(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))))
+            (operating-system
+             (inherit result)
+             (firmware target-firmwares)
+             (packages target-packages)
+             (services target-services))))
+        os-configuration
+        os-templates))
+
+;;
+;; Firewall customization
+;;
+
+(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"))))
+
+;;
+;; OS customization
+;;
+
+(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")))))
+
+(define %px-grub-theme
+  (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 
+ (ecc 
+  (curve Ed25519)
+  (q #E8322D13EA02C09F06CB70FDA2ABBFD5E463F2AA34C18C692F5E25858F4E315D#)
+  )
+ )
+"))
+
+(define (adjust-bootloader-theme config)
+  (let* ((bootloader-config (operating-system-bootloader config))
+         (bootloader (bootloader-configuration-bootloader bootloader-config)))
+    (case (bootloader-name bootloader)
+      ((grub grub-efi)
+       (bootloader-configuration
+        (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)))
+
+(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)))
+
+(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)))
+
+(define (prepare-kernel config kernel)
+  (case kernel
+    ((libre) linux-libre)
+    ((nonlibre) linux)
+    (else (operating-system-kernel config))))
+
+(define (prepare-initrd config kernel)
+  (case kernel
+    ((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))
+    (else (operating-system-firmware config))))
+
+;;
+;; OS config generation
+;;
+
+(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)
+                  (open-ports #f)
+                  (authorized-keys '())
+                  (templates '())
+                  default-packages
+                  default-services)
+  "Create <operating-system> definition based on provided templates and default
+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)))))
+  (define (apply-authorized-keys config)
+    (if (> (length authorized-keys) 0)
+        (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)))
+  (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)))