@@ -22,6 +22,8 @@
(define-module (gnu bootloader)
#:use-module (guix discovery)
+ #:use-module (guix gexp)
+ #:use-module (guix profiles)
#:use-module (guix records)
#:use-module (guix ui)
#:use-module (srfi srfi-1)
@@ -66,7 +68,9 @@
bootloader-configuration-additional-configuration
%bootloaders
- lookup-bootloader-by-name))
+ lookup-bootloader-by-name
+
+ bootloader-chain))
^L
;;;
@@ -227,3 +231,140 @@ record."
(eq? name (bootloader-name bootloader)))
(force %bootloaders))
(leave (G_ "~a: no such bootloader~%") name)))
+
+(define (bootloader-profile packages package-contents files)
+ "Creates a profile with PACKAGES and additional FILES. The new profile will
+contain a directory collection/ with links to selected PACKAGE-CONTENTS and
+FILES. This collection is meant to be used by the bootloader installer.
+
+PACKAGE-CONTENTS is a list of file or directory names relative to the PACKAGES,
+which will be symlinked into the collection/ directory. If a directory name
+ends with '/', then the directory content instead of the directory itself will
+be symlinked into the collection/ directory.
+
+FILES is a list of file like objects produced by functions like plain-file,
+local-file, etc., which will be symlinked into the collection/ directory, too."
+ (define (bootloader-collection manifest)
+ (define build
+ (with-imported-modules '((guix build utils)
+ (ice-9 ftw)
+ (srfi srfi-1))
+ #~(begin
+ (use-modules ((guix build utils) #:select (mkdir-p))
+ ((ice-9 ftw) #:select (scandir))
+ ((srfi srfi-1) #:select (append-map remove)))
+ (define (symlink-to file directory transform-name)
+ "Creates a symlink with transformed name to FILE in DIRECTORY."
+ (when (file-exists? file)
+ (symlink file
+ (string-append
+ directory "/"
+ (transform-name (basename file))))))
+ (define (remove-hash basename)
+ "Returns the basename of a store entry without the hash."
+ ;; A plain-file inside the store has a name like
+ ;; gnu/store/9x6y7j75qy9z6iv21byrbyj4yy8hb490-config.txt.
+ ;; From its basename we drop the hash.
+ ;; Therefore we expects the first '-' at index 32.
+ ;; Otherwise the basename itself is returned.
+ (if (and (> (string-length basename) 33)
+ (= (string-index basename #\- 0 33) 32))
+ (substring basename 33)
+ (basename)))
+ (define (directory-content directory)
+ "Creates a list of absolute path names inside DIRECTORY."
+ (map (lambda (name)
+ (string-append directory name))
+ (sort (or (scandir directory
+ (lambda (name)
+ (not (member name '("." "..")))))
+ '())
+ string<?)))
+ (define (select-names select names)
+ "Set SELECT to 'filter' or 'remove' names ending with '/'."
+ (select (lambda (name)
+ (string-suffix? "/" name))
+ names))
+ (define (filter-names-without-slash names)
+ (select-names remove names))
+ (define (filter-names-with-slash names)
+ (select-names filter names))
+ (let* ((collection (string-append #$output "/collection"))
+ (packages '#$(map (lambda (entry)
+ (manifest-entry-item entry))
+ (manifest-entries manifest)))
+ (contents (append-map
+ (lambda (name)
+ (map (lambda (package)
+ (string-append package "/" name))
+ packages))
+ '#$package-contents))
+ (directories (filter-names-with-slash contents))
+ (names-from-directories
+ (append-map (lambda (directory)
+ (directory-content directory))
+ directories))
+ (names (append names-from-directories
+ (filter-names-without-slash contents))))
+ (mkdir-p collection)
+ (for-each (lambda (name)
+ (symlink-to name collection identity))
+ names)
+ (for-each (lambda (file)
+ (symlink-to file collection remove-hash))
+ '#$files))
+ #t)))
+
+ (gexp->derivation "bootloader-collection"
+ build
+ #:local-build? #t
+ #:substitutable? #f
+ #:properties
+ `((type . profile-hook)
+ (hook . bootloader-collection))))
+
+ (profile (content (packages->manifest packages))
+ (name "bootloader-profile")
+ (hooks (list bootloader-collection))
+ (locales? #f)
+ (allow-collisions? #f)
+ (relative-symlinks? #f)))
+
+(define* (bootloader-chain final-bootloader
+ bootloader-packages
+ bootloader-package-contents
+ #:optional (files '())
+ #:key installer)
+ "Defines a bootloader chain with the FINAL-BOOTLOADER as the final bootloader
+and certain directories and files given in the BOOTLOADER-PACKAGE-CONTENTS list
+relative to list of BOOTLOADER-PACKAGES and additional FILES.
+
+Along with the installation of the FINAL-BOOTLOADER these additional FILES and
+BOOTLOADER-PACKAGE-CONTENTS will be copied into the bootloader target directory.
+
+If a directory name in BOOTLOADER-PACKAGE-CONTENTS ends with '/', then the
+directory content instead of the directory itself will be copied.
+
+FILES is a list of file like objects produced by functions like plain-file,
+local-file, etc.
+
+If the INSTALLER argument is used, then this will be used as the bootloader
+installer. Otherwise the intaller of the FINAL-BOOTLOADER will be used."
+ (let* ((final-installer (or installer
+ (bootloader-installer final-bootloader)))
+ (profile (bootloader-profile
+ (cons (bootloader-package final-bootloader)
+ bootloader-packages)
+ bootloader-package-contents
+ files)))
+ (bootloader
+ (inherit final-bootloader)
+ (package profile)
+ (installer
+ #~(lambda (bootloader target mount-point)
+ (#$final-installer bootloader target mount-point)
+ (copy-recursively
+ (string-append bootloader "/collection")
+ (string-append mount-point target)
+ #:follow-symlinks? #t
+ #:log (%make-void-port "w")))))))