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, 2021 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 deprecation)
  29   #:use-module ((guix ui) #:select (warn-about-load-error))
  30   #:use-module (guix diagnostics)
  31   #:use-module (guix i18n)
  32   #:use-module (srfi srfi-1)
  33   #:use-module (ice-9 match)
  34   #:export (menu-entry
  35             menu-entry?
  36             menu-entry-label
  37             menu-entry-device
  38             menu-entry-linux
  39             menu-entry-linux-arguments
  40             menu-entry-initrd
  41             menu-entry-device-mount-point
  42             menu-entry-multiboot-kernel
  43             menu-entry-multiboot-arguments
  44             menu-entry-multiboot-modules
  45
  46             menu-entry->sexp
  47             sexp->menu-entry
  48
  49             bootloader
  50             bootloader?
  51             bootloader-name
  52             bootloader-package
  53             bootloader-installer
  54             bootloader-disk-image-installer
  55             bootloader-configuration-file
  56             bootloader-configuration-file-generator
  57
  58             bootloader-configuration
  59             bootloader-configuration?
  60             bootloader-configuration-bootloader
  61             bootloader-configuration-target ;deprecated
  62             bootloader-configuration-targets
  63             bootloader-configuration-menu-entries
  64             bootloader-configuration-default-entry
  65             bootloader-configuration-timeout
  66             bootloader-configuration-keyboard-layout
  67             bootloader-configuration-theme
  68             bootloader-configuration-terminal-outputs
  69             bootloader-configuration-terminal-inputs
  70             bootloader-configuration-serial-unit
  71             bootloader-configuration-serial-speed
  72             bootloader-configuration-additional-configuration
  73
  74             %bootloaders
  75             lookup-bootloader-by-name
  76
  77             efi-bootloader-chain))
  78
  79 \f
  80 ;;;
  81 ;;; Menu-entry record.
  82 ;;;
  83
  84 (define-record-type* <menu-entry>
  85   menu-entry make-menu-entry
  86   menu-entry?
  87   (label           menu-entry-label)
  88   (device          menu-entry-device       ; file system uuid, label, or #f
  89                    (default #f))
  90   (device-mount-point menu-entry-device-mount-point
  91                    (default #f))
  92   (linux           menu-entry-linux
  93                    (default #f))
  94   (linux-arguments menu-entry-linux-arguments
  95                    (default '()))          ; list of string-valued gexps
  96   (initrd          menu-entry-initrd       ; file name of the initrd as a gexp
  97                    (default #f))
  98   (multiboot-kernel menu-entry-multiboot-kernel
  99                     (default #f))
 100   (multiboot-arguments menu-entry-multiboot-arguments
 101                        (default '()))      ; list of string-valued gexps
 102   (multiboot-modules menu-entry-multiboot-modules
 103                      (default '())))       ; list of multiboot commands, where
 104                                            ; a command is a list of <string>
 105
 106 (define (menu-entry->sexp entry)
 107   "Return ENTRY serialized as an sexp."
 108   (match entry
 109     (($ <menu-entry> label device mount-point linux linux-arguments initrd #f
 110                      ())
 111      `(menu-entry (version 0)
 112                   (label ,label)
 113                   (device ,device)
 114                   (device-mount-point ,mount-point)
 115                   (linux ,linux)
 116                   (linux-arguments ,linux-arguments)
 117                   (initrd ,initrd)))
 118     (($ <menu-entry> label device mount-point #f () #f
 119                      multiboot-kernel multiboot-arguments multiboot-modules)
 120      `(menu-entry (version 0)
 121                   (label ,label)
 122                   (device ,device)
 123                   (device-mount-point ,mount-point)
 124                   (multiboot-kernel ,multiboot-kernel)
 125                   (multiboot-arguments ,multiboot-arguments)
 126                   (multiboot-modules ,multiboot-modules)))))
 127
 128 (define (sexp->menu-entry sexp)
 129   "Turn SEXP, an sexp as returned by 'menu-entry->sexp', into a <menu-entry>
 130 record."
 131   (match sexp
 132     (('menu-entry ('version 0)
 133                   ('label label) ('device device)
 134                   ('device-mount-point mount-point)
 135                   ('linux linux) ('linux-arguments linux-arguments)
 136                   ('initrd initrd) _ ...)
 137      (menu-entry
 138       (label label)
 139       (device device)
 140       (device-mount-point mount-point)
 141       (linux linux)
 142       (linux-arguments linux-arguments)
 143       (initrd initrd)))
 144     (('menu-entry ('version 0)
 145                   ('label label) ('device device)
 146                   ('device-mount-point mount-point)
 147                   ('multiboot-kernel multiboot-kernel)
 148                   ('multiboot-arguments multiboot-arguments)
 149                   ('multiboot-modules multiboot-modules) _ ...)
 150      (menu-entry
 151       (label label)
 152       (device device)
 153       (device-mount-point mount-point)
 154       (multiboot-kernel multiboot-kernel)
 155       (multiboot-arguments multiboot-arguments)
 156       (multiboot-modules multiboot-modules)))))
 157
 158 \f
 159 ;;;
 160 ;;; Bootloader record.
 161 ;;;
 162
 163 ;; The <bootloader> record contains fields expressing how the bootloader
 164 ;; should be installed. Every bootloader in gnu/bootloader/ directory
 165 ;; has to be described by this record.
 166
 167 (define-record-type* <bootloader>
 168   bootloader make-bootloader
 169   bootloader?
 170   (name                            bootloader-name)
 171   (package                         bootloader-package)
 172   (installer                       bootloader-installer)
 173   (disk-image-installer            bootloader-disk-image-installer
 174                                    (default #f))
 175   (configuration-file              bootloader-configuration-file)
 176   (configuration-file-generator    bootloader-configuration-file-generator))
 177
 178 \f
 179 ;;;
 180 ;;; Bootloader configuration record.
 181 ;;;
 182
 183 ;; The <bootloader-configuration> record contains bootloader independant
 184 ;; configuration used to fill bootloader configuration file.
 185
 186 (define-with-syntax-properties (warn-target-field-deprecation
 187                                 (value properties))
 188   (when value
 189     (warning (source-properties->location properties)
 190              (G_ "the 'target' field is deprecated, please use 'targets' \
 191 instead~%")))
 192   value)
 193
 194 (define-record-type* <bootloader-configuration>
 195   bootloader-configuration make-bootloader-configuration
 196   bootloader-configuration?
 197   (bootloader         bootloader-configuration-bootloader) ;<bootloader>
 198   (targets            %bootloader-configuration-targets    ;list of strings
 199                       (default #f))
 200   (target             %bootloader-configuration-target ;deprecated
 201                       (default #f) (sanitize warn-target-field-deprecation))
 202   (menu-entries       bootloader-configuration-menu-entries ;list of <menu-entry>
 203                       (default '()))
 204   (default-entry      bootloader-configuration-default-entry ;integer
 205                       (default 0))
 206   (timeout            bootloader-configuration-timeout ;seconds as integer
 207                       (default 5))
 208   (keyboard-layout    bootloader-configuration-keyboard-layout ;<keyboard-layout> | #f
 209                       (default #f))
 210   (theme              bootloader-configuration-theme ;bootloader-specific theme
 211                       (default #f))
 212   (terminal-outputs   bootloader-configuration-terminal-outputs ;list of symbols
 213                       (default '(gfxterm)))
 214   (terminal-inputs    bootloader-configuration-terminal-inputs ;list of symbols
 215                       (default '()))
 216   (serial-unit        bootloader-configuration-serial-unit ;integer | #f
 217                       (default #f))
 218   (serial-speed       bootloader-configuration-serial-speed ;integer | #f
 219                       (default #f)))
 220
 221 (define-deprecated (bootloader-configuration-target config)
 222   bootloader-configuration-targets
 223   (%bootloader-configuration-target config))
 224
 225 (define (bootloader-configuration-targets config)
 226   (or (%bootloader-configuration-targets config)
 227       ;; TODO: Remove after the deprecated 'target' field is removed.
 228       (list (%bootloader-configuration-target config))
 229       ;; XXX: At least the GRUB installer (see (gnu bootloader grub)) has this
 230       ;; peculiar behavior of installing fonts and GRUB modules when DEVICE is #f,
 231       ;; hence the default value of '(#f) rather than '().
 232       (list #f)))
 233
 234 \f
 235 ;;;
 236 ;;; Bootloaders.
 237 ;;;
 238
 239 (define (bootloader-modules)
 240   "Return the list of bootloader modules."
 241   (all-modules (map (lambda (entry)
 242                       `(,entry . "gnu/bootloader"))
 243                     %load-path)
 244                #:warn warn-about-load-error))
 245
 246 (define %bootloaders
 247   ;; The list of publically-known bootloaders.
 248   (delay (fold-module-public-variables (lambda (obj result)
 249                                          (if (bootloader? obj)
 250                                              (cons obj result)
 251                                              result))
 252                                        '()
 253                                        (bootloader-modules))))
 254
 255 (define (lookup-bootloader-by-name name)
 256   "Return the bootloader called NAME."
 257   (or (find (lambda (bootloader)
 258               (eq? name (bootloader-name bootloader)))
 259             (force %bootloaders))
 260       (leave (G_ "~a: no such bootloader~%") name)))
 261
 262 (define (efi-bootloader-profile files bootloader-package hooks)
 263   "Creates a profile with BOOTLOADER-PACKAGE and a directory collection/ with
 264 links to additional FILES from the store.  This collection is meant to be used
 265 by the bootloader installer.
 266
 267 FILES is a list of file or directory names from the store, which will be
 268 symlinked into the collection/ directory.  If a directory name ends with '/',
 269 then the directory content instead of the directory itself will be symlinked
 270 into the collection/ directory.
 271
 272 FILES may contain file like objects produced by functions like plain-file,
 273 local-file, etc., or package contents produced with file-append.
 274
 275 HOOKS lists additional hook functions to modify the profile."
 276   (define (bootloader-collection manifest)
 277     (define build
 278         (with-imported-modules '((guix build utils)
 279                                  (ice-9 ftw)
 280                                  (srfi srfi-1)
 281                                  (srfi srfi-26))
 282           #~(begin
 283             (use-modules ((guix build utils)
 284                           #:select (mkdir-p strip-store-file-name))
 285                          ((ice-9 ftw)
 286                           #:select (scandir))
 287                          ((srfi srfi-1)
 288                           #:select (append-map every remove))
 289                          ((srfi srfi-26)
 290                           #:select (cut)))
 291             (define (symlink-to file directory transform)
 292               "Creates a symlink to FILE named (TRANSFORM FILE) in DIRECTORY."
 293               (symlink file (string-append directory "/" (transform file))))
 294             (define (directory-content directory)
 295               "Creates a list of absolute path names inside DIRECTORY."
 296               (map (lambda (name)
 297                      (string-append directory name))
 298                    (or (scandir directory (lambda (name)
 299                                             (not (member name '("." "..")))))
 300                        '())))
 301             (define name-ends-with-/? (cut string-suffix? "/" <>))
 302             (define (name-is-store-entry? name)
 303               "Return #t if NAME is a direct store entry and nothing inside."
 304               (not (string-index (strip-store-file-name name) #\/)))
 305             (let* ((collection (string-append #$output "/collection"))
 306                    (files '#$files)
 307                    (directories (filter name-ends-with-/? files))
 308                    (names-from-directories
 309                     (append-map (lambda (directory)
 310                                   (directory-content directory))
 311                                 directories))
 312                    (names (append names-from-directories
 313                                   (remove name-ends-with-/? files))))
 314               (mkdir-p collection)
 315               (if (every file-exists? names)
 316                   (begin
 317                     (for-each (lambda (name)
 318                                (symlink-to name collection
 319                                             (if (name-is-store-entry? name)
 320                                                 strip-store-file-name
 321                                                 basename)))
 322                               names)
 323                     #t)
 324                   #f)))))
 325
 326     (gexp->derivation "bootloader-collection"
 327                       build
 328                       #:local-build? #t
 329                       #:substitutable? #f
 330                       #:properties
 331                       `((type . profile-hook)
 332                         (hook . bootloader-collection))))
 333
 334   (profile (content (packages->manifest (list bootloader-package)))
 335            (name "bootloader-profile")
 336            (hooks (append (list bootloader-collection) hooks))
 337            (locales? #f)
 338            (allow-collisions? #f)
 339            (relative-symlinks? #f)))
 340
 341 (define* (efi-bootloader-chain files
 342                                final-bootloader
 343                                #:key
 344                                (hooks '())
 345                                installer)
 346   "Define a bootloader chain with FINAL-BOOTLOADER as the final bootloader and
 347 certain directories and files from the store given in the list of FILES.
 348
 349 FILES may contain file like objects produced by functions like plain-file,
 350 local-file, etc., or package contents produced with file-append.  They will be
 351 collected inside a directory collection/ inside a generated bootloader profile,
 352 which will be passed to the INSTALLER.
 353
 354 If a directory name in FILES ends with '/', then the directory content instead
 355 of the directory itself will be symlinked into the collection/ directory.
 356
 357 The procedures in the HOOKS list can be used to further modify the bootloader
 358 profile.  It is possible to pass a single function instead of a list.
 359
 360 If the INSTALLER argument is used, then this function will be called to install
 361 the bootloader.  Otherwise the installer of the FINAL-BOOTLOADER will be called."
 362   (let* ((final-installer (or installer
 363                               (bootloader-installer final-bootloader)))
 364          (profile (efi-bootloader-profile files
 365                                           (bootloader-package final-bootloader)
 366                                           (if (list? hooks)
 367                                               hooks
 368                                               (list hooks)))))
 369     (bootloader
 370      (inherit final-bootloader)
 371      (package profile)
 372      (installer
 373       #~(lambda (bootloader target mount-point)
 374           (#$final-installer bootloader target mount-point)
 375           (copy-recursively
 376            (string-append bootloader "/collection")
 377            (string-append mount-point target)
 378            #:follow-symlinks? #t
 379            #:log (%make-void-port "w")))))))