From 48919710c919eaf86a3d4f76aafd8f5ed4d9945a Mon Sep 17 00:00:00 2001
From: Rutherther <rutherther@ditigal.xyz>
Date: Sun, 22 Jun 2025 09:34:48 +0200
Subject: [PATCH] feat: Add image builder

---
 modules/zynqmp/build/bootloader.scm |  27 ++++
 modules/zynqmp/packages/images.scm  | 197 ++++++++++++++++++++++++++++
 2 files changed, 224 insertions(+)
 create mode 100644 modules/zynqmp/build/bootloader.scm
 create mode 100644 modules/zynqmp/packages/images.scm

diff --git a/modules/zynqmp/build/bootloader.scm b/modules/zynqmp/build/bootloader.scm
new file mode 100644
index 0000000..e34cbcc
--- /dev/null
+++ b/modules/zynqmp/build/bootloader.scm
@@ -0,0 +1,27 @@
+(define-module (zynqmp build bootloader)
+  #:use-module (srfi srfi-28)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 match)
+  #:export (bootcfg-entry->config-menu-entry
+            get-required-files))
+
+(define (bootcfg-entry->config-menu-entry entry)
+                (match entry
+                  ((label kernel kernel-arguments initrd)
+                   (format "LABEL ~a
+  MENU LABEL ~a
+  KERNEL ~a
+  FDT /system.dtb
+  INITRD ~a
+  APPEND ~a
+~%" label label kernel initrd (string-join kernel-arguments)))))
+
+(define (get-required-files entries)
+  (delete-duplicates (apply
+                      append
+                      (map
+                       (lambda (entry)
+                         (match entry
+                           ((label kernel kernel-arguments initrd)
+                            (list kernel initrd))))
+                       entries))))
diff --git a/modules/zynqmp/packages/images.scm b/modules/zynqmp/packages/images.scm
new file mode 100644
index 0000000..aeebdd2
--- /dev/null
+++ b/modules/zynqmp/packages/images.scm
@@ -0,0 +1,197 @@
+(define-module (zynqmp packages images)
+  #:use-module (zynqmp packages bootloader)
+  #:use-module (zynqmp packages linux)
+  #:use-module (guix packages)
+  #:use-module (guix modules)
+  #:use-module (guix gexp)
+  #:use-module (guix build-system trivial)
+  #:use-module (gnu services base)
+  #:use-module (gnu packages base)
+  #:use-module (gnu system)
+  #:use-module (gnu system shadow)
+  #:use-module (gnu system nss)
+  #:use-module (gnu system image)
+  #:use-module (gnu image)
+  #:use-module (gnu bootloader extlinux)
+  #:use-module (gnu bootloader))
+
+(define root-offset (* 512 2048))
+
+;; TODO: FDT
+(define* (install-xilinx-bootloader fdt)
+  (with-imported-modules '((zynqmp build bootloader))
+    #~(begin
+        (use-modules (zynqmp build bootloader))
+
+        (lambda (bootloader device mount-point)
+          (let* ((bootcfg-file (string-append (getcwd) "/" mount-point "/bootcfg"))
+                 (bootcfg (load bootcfg-file)))
+
+            ;; Configuration
+            (mkdir-p (string-append mount-point "/extlinux"))
+            (call-with-output-file
+                (string-append mount-point "/extlinux/extlinux.conf")
+              (lambda (port)
+                (display (apply string-append (map bootcfg-entry->config-menu-entry bootcfg)) port)))
+
+            ;; GNU store needed files
+            (for-each
+             (lambda (source-file)
+               (let* ((dest-file (string-append mount-point source-file)))
+                 (mkdir-p (dirname dest-file))
+                 (copy-recursively source-file dest-file)))
+             (get-required-files bootcfg))
+
+
+            (copy-file (string-append bootloader "/libexec/boot.bin")
+                       (string-append mount-point "/boot.bin"))
+            (copy-file (string-append bootloader "/libexec/u-boot.itb")
+                       (string-append mount-point "/u-boot.itb"))
+
+            ;; From the first element extract linux.
+            ;; There can be just one fdt file... the first element should be the newest...
+            (let* ((entry (list-ref bootcfg 0))
+                   (linux (list-ref entry 1))
+                   (linux-dir (dirname linux)))
+              (copy-file (string-append linux-dir "/lib/dtbs/" #$fdt ".dtb")
+                         (string-append mount-point "/system.dtb"))))))))
+
+;; This is just a configuration stub. Actually it will write the bootcfg to a file.
+;; This file is then consumed by the install bootloader script. And this script
+;; will generate the proper configuration
+(define* (xilinx-external-bootloader-configuration config entries #:key #:allow-other-keys)
+  (define all-entries
+    (append entries (bootloader-configuration-menu-entries config)))
+
+  (define (menu-entry->gexp entry)
+    (let ((label (menu-entry-label entry))
+          (kernel (menu-entry-linux entry))
+          (kernel-arguments (menu-entry-linux-arguments entry))
+          (initrd (menu-entry-initrd entry)))
+      #~(list #$label #$kernel (list #$@kernel-arguments) #$initrd)))
+
+  (define builder
+    #~(call-with-output-file #$output
+        (lambda (port)
+          (write '(list #$@(map menu-entry->gexp all-entries)) port))))
+
+  (computed-file "bootcfg" builder))
+
+(define xilinx-bootloader
+  (bootloader
+   (inherit extlinux-bootloader)
+   (name 'xilinx-uboot)
+   (package u-boot-for-kr260)
+   (configuration-file-generator xilinx-external-bootloader-configuration)
+   (installer (install-xilinx-bootloader "xilinx/zynqmp-smk-k26-revA-sck-kr-g-revB"))
+   (configuration-file "/bootcfg")))
+
+(define root-partition
+  (partition
+   (size 'guess)
+   (label "root")
+   (file-system "ext4")
+   ;; Disable the metadata_csum and 64bit features of ext4, for compatibility
+   ;; with U-Boot.
+   (file-system-options (list "-O" "^metadata_csum,^64bit"))
+   (flags '(boot))
+   (initializer
+    #~(lambda* (root #:key
+                 (copy-closures? #t)
+                 (deduplicate? #t)
+                 references-graphs
+                 (register-closures? #t)
+                 system-directory
+                 make-device-nodes
+                 (wal-mode? #t)
+                 #:allow-other-keys)
+        (initialize-root-partition root
+                                   #:bootcfg #f
+                                   #:bootcfg-location #f
+                                   #:bootloader-package #f
+                                   #:bootloader-installer #f
+                                   #:copy-closures? copy-closures?
+                                   #:deduplicate? deduplicate?
+                                   #:references-graphs references-graphs
+                                   #:system-directory system-directory
+                                   #:make-device-nodes make-device-nodes
+                                   #:wal-mode? wal-mode?)))))
+
+(define boot-partition
+  (partition
+   (size (* 256 1024 1024))
+   (label "BOOT")
+   (file-system "vfat")
+   (offset root-offset)
+   (flags '())
+   (initializer
+    (with-imported-modules (source-module-closure
+                            '((guix build utils)
+                              (gnu build install)))
+      #~(lambda* (root #:key
+                   bootcfg
+                   bootcfg-location
+                   bootloader-package
+                   bootloader-installer
+                   (copy-closures? #t)
+                   (deduplicate? #t)
+                   references-graphs
+                   (register-closures? #t)
+                   system-directory
+                   make-device-nodes
+                   (wal-mode? #t)
+                   #:allow-other-keys)
+          (use-modules (gnu build install))
+          (mkdir-p root)
+          (when bootcfg
+            (install-boot-config bootcfg bootcfg-location root))
+          (when bootloader-installer
+            (display "installing bootloader...\n")
+            (bootloader-installer bootloader-package #f root)
+            (display "bootloader installed...\n")))))))
+
+(define os
+  (operating-system
+    (host-name "guix")
+    (timezone "Europe/Prague")
+    (bootloader
+     (bootloader-configuration
+      (bootloader xilinx-bootloader)))
+    (kernel-arguments '("console=ttyPS1,115200"))
+    (kernel xilinx-linux-for-zynqmp)
+    (initrd-modules '())
+    (file-systems (list)) ; Doesn't matter as replaced by image
+    (users %base-user-accounts)
+    (packages %base-packages)
+    (services %base-services)
+    (name-service-switch %mdns-host-lookup-nss)))
+
+(define-public zynqmp-base-image
+  (image
+   (operating-system os)
+   (format 'disk-image)
+   (partition-table-type 'mbr) ;; TODO
+   (volatile-root? #f)
+   (partitions
+    (list boot-partition
+          root-partition))))
+
+(define-public zynqmp-base-system-image
+  (package
+    (name "zynqmp-base-system-image.img")
+    (version "0")
+    (source #f)
+    (build-system trivial-build-system)
+    (arguments
+     (list
+      #:modules '((guix build utils))
+      #:builder
+      #~(begin
+          (use-modules (guix build utils))
+          (symlink
+           #$(system-image zynqmp-base-image)
+           #$output))))
+    (synopsis #f)
+    (home-page #f)
+    (license #f)
+    (description #f)))
-- 
2.49.0