guix-channel

 1(define-module (nmeum bootloader grub)
 2  #:use-module (gnu)
 3  #:use-module (gnu bootloader)
 4  #:use-module (gnu bootloader grub)
 5  #:use-module (guix gexp)
 6  #:use-module (guix import utils)
 7  #:use-module ((srfi srfi-1) #:select (break))
 8  #:use-module ((srfi srfi-11) #:select (let-values)))
 9
10;; wraps an existing Grub 'bootloader-installer' in a procedure which copies
11;; all files referenced in Grub's configuration file to the install directory.
12;;
13;; TODO: make use of the new in-vicinity procedure (unreleased in GNU Guile).
14;; See https://cgit.git.savannah.gnu.org/cgit/guile.git/commit/?id=755f703dcb3110e1920e42078edc6d9c88cc8b28
15(define-public (grub-copy installer)
16  #~(lambda (bootloader device mount-point)
17      (use-modules ((srfi srfi-1) #:select (fold lset-adjoin lset-difference))
18                   ((guix import utils) #:select (read-lines))
19                   ((guix store) #:select (direct-store-path))
20                   (ice-9 regex))
21
22      ;; regex for finding a path to the Store in the Grub configuration file.
23      ;; Obviously a heurstic, ideally we would get this information from Grub.
24      (define store-regexp (make-regexp "/gnu/store/[A-Za-z0-9@/._-]+"))
25
26      ;; regex for finding the linux command in a Grub configuration file.
27      ;; See https://www.gnu.org/software/grub/manual/grub/grub.html#linux
28      (define linux-regexp (make-regexp "^[[:space:]]*linux[[:space:]]"))
29
30      ;; Takes a list of /gnu/store paths and returns a list of unique directory
31      ;; entries in the /gnu/store directory (usually: hash + package + version).
32      (define (store-entries paths)
33        (fold
34          (lambda (path acc)
35            (lset-adjoin
36              equal?
37              acc
38              (substring (direct-store-path path) (string-length "/gnu/store"))))
39          '() paths))
40
41      (define (required-paths lines)
42        (fold
43          (lambda (line acc)
44            (let ((paths (map match:substring (list-matches store-regexp line))))
45              (if (null? paths)
46                acc
47                (if (regexp-exec linux-regexp line) ; ignore kernel cmdline paths
48                  (lset-adjoin equal? acc (car paths))
49                  (apply lset-adjoin (cons* equal? acc paths))))))
50          '() lines))
51
52      (define (existing-paths store)
53        (map
54          (lambda (path)
55            (substring path (string-length "/boot")))
56          (find-files store)))
57
58      (let* ((install-dir (canonicalize-path (string-append mount-point "/boot")))
59             (grub-cfg (string-append install-dir "/grub/grub.cfg"))
60             (grub-lines (call-with-input-file grub-cfg read-lines))
61             (required (required-paths grub-lines))
62             (existing (existing-paths (string-append install-dir "/gnu/store"))))
63        (for-each ; remove leftovers from old generations
64          (lambda (store-entry)
65            (delete-file-recursively
66              (string-append install-dir "/gnu/store/" store-entry)))
67          (lset-difference equal? (store-entries existing) (store-entries required)))
68        (for-each ; copy required files
69          (lambda (store-file)
70            (let ((dest-file (string-append install-dir store-file)))
71              (mkdir-p (dirname dest-file))
72              (copy-recursively store-file dest-file)))
73          required))
74
75      ;; Invoke the 'bootloader-installer' that we are wrapping.
76      (#$installer bootloader device mount-point)))
77
78;; wraps an existing 'bootloader-configuration-file-generator' and removes
79;; any '#:store-crypto-devices' from the arguments passed to the generator.
80(define-public (configuration-file-generator-without-crypto-devices generator)
81  (define (filter-keyword keyword args)
82        (let-values (((head tail) (break
83                                    (lambda (arg)
84                                      (equal? arg keyword))
85                                    args)))
86          (if (null? tail)
87            args
88            (append head (cdr (cdr tail))))))
89
90  (lambda args
91    (apply
92      generator
93      (filter-keyword #:store-crypto-devices args))))