gnu/bootloader.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2017 David Craven <david@craven.ch>
   3 ;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
   4 ;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
   5 ;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
   6 ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
   7 ;;;
   8 ;;; This file is part of GNU Guix.
   9 ;;;
  10 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  11 ;;; under the terms of the GNU General Public License as published by
  12 ;;; the Free Software Foundation; either version 3 of the License, or (at
  13 ;;; your option) any later version.
  14 ;;;
  15 ;;; GNU Guix is distributed in the hope that it will be useful, but
  16 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;;; GNU General Public License for more details.
  19 ;;;
  20 ;;; You should have received a copy of the GNU General Public License
  21 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 (define-module (gnu bootloader)
  24   #:use-module (guix discovery)
  25   #:use-module (guix gexp)
  26   #:use-module (guix profiles)
  27   #:use-module (guix records)
  28   #:use-module (guix ui)
  29   #:use-module (srfi srfi-1)
  30   #:use-module (ice-9 match)
  31   #:export (menu-entry
  32             menu-entry?
  33             menu-entry-label
  34             menu-entry-device
  35             menu-entry-linux
  36             menu-entry-linux-arguments
  37             menu-entry-initrd
  38             menu-entry-device-mount-point
  39             menu-entry-multiboot-kernel
  40             menu-entry-multiboot-arguments
  41             menu-entry-multiboot-modules
  42
  43             menu-entry->sexp
  44             sexp->menu-entry
  45
  46             bootloader
  47             bootloader?
  48             bootloader-name
  49             bootloader-package
  50             bootloader-installer
  51             bootloader-disk-image-installer
  52             bootloader-configuration-file
  53             bootloader-configuration-file-generator
  54
  55             bootloader-configuration
  56             bootloader-configuration?
  57             bootloader-configuration-bootloader
  58             bootloader-configuration-target
  59             bootloader-configuration-menu-entries
  60             bootloader-configuration-default-entry
  61             bootloader-configuration-timeout
  62             bootloader-configuration-keyboard-layout
  63             bootloader-configuration-theme
  64             bootloader-configuration-terminal-outputs
  65             bootloader-configuration-terminal-inputs
  66             bootloader-configuration-serial-unit
  67             bootloader-configuration-serial-speed
  68             bootloader-configuration-additional-configuration
  69
  70             %bootloaders
  71             lookup-bootloader-by-name
  72
  73             efi-bootloader-chain))
  74
  75 \f
  76 ;;;
  77 ;;; Menu-entry record.
  78 ;;;
  79
  80 (define-record-type* <menu-entry>
  81   menu-entry make-menu-entry
  82   menu-entry?
  83   (label           menu-entry-label)
  84   (device          menu-entry-device       ; file system uuid, label, or #f
  85                    (default #f))
  86   (device-mount-point menu-entry-device-mount-point
  87                    (default #f))
  88   (linux           menu-entry-linux
  89                    (default #f))
  90   (linux-arguments menu-entry-linux-arguments
  91                    (default '()))          ; list of string-valued gexps
  92   (initrd          menu-entry-initrd       ; file name of the initrd as a gexp
  93                    (default #f))
  94   (multiboot-kernel menu-entry-multiboot-kernel
  95                     (default #f))
  96   (multiboot-arguments menu-entry-multiboot-arguments
  97                        (default '()))      ; list of string-valued gexps
  98   (multiboot-modules menu-entry-multiboot-modules
  99                      (default '())))       ; list of multiboot commands, where
 100                                            ; a command is a list of <string>
 101
 102 (define (menu-entry->sexp entry)
 103   "Return ENTRY serialized as an sexp."
 104   (match entry
 105     (($ <menu-entry> label device mount-point linux linux-arguments initrd #f
 106                      ())
 107      `(menu-entry (version 0)
 108                   (label ,label)
 109                   (device ,device)
 110                   (device-mount-point ,mount-point)
 111                   (linux ,linux)
 112                   (linux-arguments ,linux-arguments)
 113                   (initrd ,initrd)))
 114     (($ <menu-entry> label device mount-point #f () #f
 115                      multiboot-kernel multiboot-arguments multiboot-modules)
 116      `(menu-entry (version 0)
 117                   (label ,label)
 118                   (device ,device)
 119                   (device-mount-point ,mount-point)
 120                   (multiboot-kernel ,multiboot-kernel)
 121                   (multiboot-arguments ,multiboot-arguments)
 122                   (multiboot-modules ,multiboot-modules)))))
 123
 124 (define (sexp->menu-entry sexp)
 125   "Turn SEXP, an sexp as returned by 'menu-entry->sexp', into a <menu-entry>
 126 record."
 127   (match sexp
 128     (('menu-entry ('version 0)
 129                   ('label label) ('device device)
 130                   ('device-mount-point mount-point)
 131                   ('linux linux) ('linux-arguments linux-arguments)
 132                   ('initrd initrd) _ ...)
 133      (menu-entry
 134       (label label)
 135       (device device)
 136       (device-mount-point mount-point)
 137       (linux linux)
 138       (linux-arguments linux-arguments)
 139       (initrd initrd)))
 140     (('menu-entry ('version 0)
 141                   ('label label) ('device device)
 142                   ('device-mount-point mount-point)
 143                   ('multiboot-kernel multiboot-kernel)
 144                   ('multiboot-arguments multiboot-arguments)
 145                   ('multiboot-modules multiboot-modules) _ ...)
 146      (menu-entry
 147       (label label)
 148       (device device)
 149       (device-mount-point mount-point)
 150       (multiboot-kernel multiboot-kernel)
 151       (multiboot-arguments multiboot-arguments)
 152       (multiboot-modules multiboot-modules)))))
 153
 154 \f
 155 ;;;
 156 ;;; Bootloader record.
 157 ;;;
 158
 159 ;; The <bootloader> record contains fields expressing how the bootloader
 160 ;; should be installed. Every bootloader in gnu/bootloader/ directory
 161 ;; has to be described by this record.
 162
 163 (define-record-type* <bootloader>
 164   bootloader make-bootloader
 165   bootloader?
 166   (name                            bootloader-name)
 167   (package                         bootloader-package)
 168   (installer                       bootloader-installer)
 169   (disk-image-installer            bootloader-disk-image-installer
 170                                    (default #f))
 171   (configuration-file              bootloader-configuration-file)
 172   (configuration-file-generator    bootloader-configuration-file-generator))
 173
 174 \f
 175 ;;;
 176 ;;; Bootloader configuration record.
 177 ;;;
 178
 179 ;; The <bootloader-configuration> record contains bootloader independant
 180 ;; configuration used to fill bootloader configuration file.
 181
 182 (define-record-type* <bootloader-configuration>
 183   bootloader-configuration make-bootloader-configuration
 184   bootloader-configuration?
 185   (bootloader         bootloader-configuration-bootloader) ;<bootloader>
 186   (target             bootloader-configuration-target      ;string
 187                       (default #f))
 188   (menu-entries       bootloader-configuration-menu-entries ;list of <menu-entry>
 189                       (default '()))
 190   (default-entry      bootloader-configuration-default-entry ;integer
 191                       (default 0))
 192   (timeout            bootloader-configuration-timeout ;seconds as integer
 193                       (default 5))
 194   (keyboard-layout    bootloader-configuration-keyboard-layout ;<keyboard-layout> | #f
 195                       (default #f))
 196   (theme              bootloader-configuration-theme ;bootloader-specific theme
 197                       (default #f))
 198   (terminal-outputs   bootloader-configuration-terminal-outputs ;list of symbols
 199                       (default '(gfxterm)))
 200   (terminal-inputs    bootloader-configuration-terminal-inputs ;list of symbols
 201                       (default '()))
 202   (serial-unit        bootloader-configuration-serial-unit ;integer | #f
 203                       (default #f))
 204   (serial-speed       bootloader-configuration-serial-speed ;integer | #f
 205                       (default #f)))
 206
 207 \f
 208 ;;;
 209 ;;; Bootloaders.
 210 ;;;
 211
 212 (define (bootloader-modules)
 213   "Return the list of bootloader modules."
 214   (all-modules (map (lambda (entry)
 215                       `(,entry . "gnu/bootloader"))
 216                     %load-path)
 217                #:warn warn-about-load-error))
 218
 219 (define %bootloaders
 220   ;; The list of publically-known bootloaders.
 221   (delay (fold-module-public-variables (lambda (obj result)
 222                                          (if (bootloader? obj)
 223                                              (cons obj result)
 224                                              result))
 225                                        '()
 226                                        (bootloader-modules))))
 227
 228 (define (lookup-bootloader-by-name name)
 229   "Return the bootloader called NAME."
 230   (or (find (lambda (bootloader)
 231               (eq? name (bootloader-name bootloader)))
 232             (force %bootloaders))
 233       (leave (G_ "~a: no such bootloader~%") name)))
 234
 235 (define (efi-bootloader-profile files bootloader-package hooks)
 236   "Creates a profile with BOOTLOADER-PACKAGE and a directory collection/ with
 237 links to additional FILES from the store.  This collection is meant to be used
 238 by the bootloader installer.
 239
 240 FILES is a list of file or directory names from the store, which will be
 241 symlinked into the collection/ directory.  If a directory name ends with '/',
 242 then the directory content instead of the directory itself will be symlinked
 243 into the collection/ directory.
 244
 245 FILES may contain file like objects produced by functions like plain-file,
 246 local-file, etc., or package contents produced with file-append.
 247
 248 HOOKS lists additional hook functions to modify the profile."
 249   (define (bootloader-collection manifest)
 250     (define build
 251         (with-imported-modules '((guix build utils)
 252                                  (ice-9 ftw)
 253                                  (srfi srfi-1)
 254                                  (srfi srfi-26))
 255           #~(begin
 256             (use-modules ((guix build utils)
 257                           #:select (mkdir-p strip-store-file-name))
 258                          ((ice-9 ftw)
 259                           #:select (scandir))
 260                          ((srfi srfi-1)
 261                           #:select (append-map every remove))
 262                          ((srfi srfi-26)
 263                           #:select (cut)))
 264             (define (symlink-to file directory transform)
 265               "Creates a symlink to FILE named (TRANSFORM FILE) in DIRECTORY."
 266               (symlink file (string-append directory "/" (transform file))))
 267             (define (directory-content directory)
 268               "Creates a list of absolute path names inside DIRECTORY."
 269               (map (lambda (name)
 270                      (string-append directory name))
 271                    (or (scandir directory (lambda (name)
 272                                             (not (member name '("." "..")))))
 273                        '())))
 274             (define name-ends-with-/? (cut string-suffix? "/" <>))
 275             (define (name-is-store-entry? name)
 276               "Return #t if NAME is a direct store entry and nothing inside."
 277               (not (string-index (strip-store-file-name name) #\/)))
 278             (let* ((collection (string-append #$output "/collection"))
 279                    (files '#$files)
 280                    (directories (filter name-ends-with-/? files))
 281                    (names-from-directories
 282                     (append-map (lambda (directory)
 283                                   (directory-content directory))
 284                                 directories))
 285                    (names (append names-from-directories
 286                                   (remove name-ends-with-/? files))))
 287               (mkdir-p collection)
 288               (if (every file-exists? names)
 289                   (begin
 290                     (for-each (lambda (name)
 291                                (symlink-to name collection
 292                                             (if (name-is-store-entry? name)
 293                                                 strip-store-file-name
 294                                                 basename)))
 295                               names)
 296                     #t)
 297                   #f)))))
 298
 299     (gexp->derivation "bootloader-collection"
 300                       build
 301                       #:local-build? #t
 302                       #:substitutable? #f
 303                       #:properties
 304                       `((type . profile-hook)
 305                         (hook . bootloader-collection))))
 306
 307   (profile (content (packages->manifest (list bootloader-package)))
 308            (name "bootloader-profile")
 309            (hooks (append (list bootloader-collection) hooks))
 310            (locales? #f)
 311            (allow-collisions? #f)
 312            (relative-symlinks? #f)))
 313
 314 (define* (efi-bootloader-chain files
 315                                final-bootloader
 316                                #:key
 317                                (hooks '())
 318                                installer)
 319   "Define a bootloader chain with FINAL-BOOTLOADER as the final bootloader and
 320 certain directories and files from the store given in the list of FILES.
 321
 322 FILES may contain file like objects produced by functions like plain-file,
 323 local-file, etc., or package contents produced with file-append.  They will be
 324 collected inside a directory collection/ inside a generated bootloader profile,
 325 which will be passed to the INSTALLER.
 326
 327 If a directory name in FILES ends with '/', then the directory content instead
 328 of the directory itself will be symlinked into the collection/ directory.
 329
 330 The procedures in the HOOKS list can be used to further modify the bootloader
 331 profile.  It is possible to pass a single function instead of a list.
 332
 333 If the INSTALLER argument is used, then this function will be called to install
 334 the bootloader.  Otherwise the installer of the FINAL-BOOTLOADER will be called."
 335   (let* ((final-installer (or installer
 336                               (bootloader-installer final-bootloader)))
 337          (profile (efi-bootloader-profile files
 338                                           (bootloader-package final-bootloader)
 339                                           (if (list? hooks)
 340                                               hooks
 341                                               (list hooks)))))
 342     (bootloader
 343      (inherit final-bootloader)
 344      (package profile)
 345      (installer
 346       #~(lambda (bootloader target mount-point)
 347           (#$final-installer bootloader target mount-point)
 348           (copy-recursively
 349            (string-append bootloader "/collection")
 350            (string-append mount-point target)
 351            #:follow-symlinks? #t
 352            #:log (%make-void-port "w")))))))