guix/gnu/build/bootloader.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2022 Denis 'GNUtoo' Carikli <GNUtoo@cyberdimension.org>
;;; Copyright © 2022 Timothy Sample <samplet@ngyro.com>
;;; Copyright © 2024 Lilah Tascheter <lilah@lunabee.space>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu build bootloader)
  #:autoload   (guix build syscalls) (free-disk-space)
  #:use-module (guix build utils)
  #:use-module (guix diagnostics)
  #:use-module (guix i18n)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (ice-9 popen)
  #:use-module (ice-9 receive)
  #:use-module (ice-9 regex)
  #:use-module (rnrs io ports)
  #:use-module (rnrs io simple)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-35)
  #:export (atomic-copy
            in-temporary-directory
            write-file-on-device
            install-efi))


;;;
;;; Writing utils.
;;;

(define (atomic-copy from to)
  (let ((pivot (string-append to ".new")))
    (copy-file from pivot)
    (rename-file pivot to)))

(define-syntax-rule (in-temporary-directory blocks ...)
  "Run BLOCKS while chdir'd into a temporary directory."
  ;; Under POSIX.1-2008, mkdtemp must make the dir with 700 perms.
  (let* ((tmp (or (getenv "TMPDIR") "/tmp"))
         (dir (mkdtemp (string-append tmp "/guix-bootloader.XXXXXX")))
         (cwd (getcwd)))
    (dynamic-wind (lambda () (chdir dir))
                  (lambda () blocks ...)
                  (lambda () (chdir cwd) (delete-file-recursively dir)))))

(define (write-file-on-device file size device offset)
  "Write SIZE bytes from FILE to DEVICE starting at OFFSET."
  (call-with-input-file file
    (lambda (input)
      (let ((bv (get-bytevector-n input size)))
        (call-with-port
         ;; Do not use "call-with-output-file" that would truncate the file.
         (open-file-output-port device
                                (file-options no-truncate no-fail)
                                (buffer-mode block)
                                ;; Use the binary-friendly ISO-8859-1
                                ;; encoding.
                                (make-transcoder (latin-1-codec)))
         (lambda (output)
           (seek output offset SEEK_SET)
           (put-bytevector output bv)))))))


;;;
;;; EFI bootloader.
;;;

;; XXX: Parsing efibootmgr output may be kinda jank.  A better way may exist.
(define (efi-bootnums efibootmgr)
  "Returns '(path . bootnum) pairs for each EFI boot entry.  bootnum is
a string, and path is backslash-deliminated and relative to the ESP."
  (let* ((pipe (open-pipe* OPEN_READ efibootmgr))
         (text (get-string-all pipe))
         (status (status:exit-val (close-pipe pipe)))
         (bootnum-pattern
           "^Boot([0-9a-fA-F]+).*[^A-Za-z]File\\(([^)]+)\\)$"))
    (unless (zero? status)
      (raise-exception
        (formatted-message (G_ "efibootmgr exited with error code ~a") status)))
    (fold-matches (make-regexp bootnum-pattern regexp/newline) text '()
                  (lambda (match acc)
                    (let* ((path (match:substring match 2))
                           (bootnum (match:substring match 1)))
                      (cons (cons path bootnum) acc))))))

(define (install-efi efibootmgr vendir loader* disk plan)
  "See also install-efi in (gnu bootloader)."
  (let* ((loader (string-map (match-lambda (#\/ #\\) (x x)) loader*))
         (bootnums (filter (compose (cut string-prefix? loader <>) car)
                     (efi-bootnums efibootmgr)))
         (plan-files (map cadr plan)))
    (define (size file) (if (file-exists? file) (stat:size (stat file)) 0))
    (define (vendirof file) (string-append vendir "/" file))
    (define (loaderof file) (string-append loader "\\" file))
    (define (delete-boot num file)
      (invoke efibootmgr "--quiet" "--bootnum" num "--delete-bootnum")
      (when (file-exists? file) (delete-file file)))

    (mkdir-p vendir)
    ;; Delete old entries first, to clear up space.
    (for-each (lambda (spec) ; '(path . bootnum)
                (let* ((s (substring (car spec) (string-length loader)))
                       (file (substring s (if (string-prefix? "\\" s) 1 0))))
                  (unless (member file plan-files)
                    (delete-boot (cdr spec) (vendirof file)))))
      bootnums)
    ;; New and updated entries.
    (in-temporary-directory
      (for-each
        (lambda (spec)
          (let* ((builder (car spec)) (name (cadr spec))
                 (dest (vendirof name)) (loadest (loaderof name))
                 (rest (reverse (cdr (member name plan-files)))))
            ;; Build to a temporary file so we can check its size.
            (builder name)
            ;; Disk space is usually limited on ESPs.
            ;; Try to clear space as we install new bootloaders.
            (if (while (> (- (size name) (size dest)) (free-disk-space vendir))
                  (let ((del (find (compose file-exists? vendirof) rest)))
                    (if del (delete-file (vendirof del)) (break #t))))
                (begin
                  (and=> (assoc-ref bootnums loadest) (cut delete-boot <> dest))
                  (warning (G_ "ESP too small for bootloader ~a!~%") name))
                ;; The ESP is too small for atomic copy.
                (begin
                  (copy-file name dest)
                  (unless (assoc loadest bootnums)
                    (invoke
                      efibootmgr "--quiet" "--create-only" "--label"
                      (cddr spec) "--disk" disk "--loader" loadest))))
            (delete-file name)))
        plan))
    ;; Verify that at least the first entry was installed.
    (unless (file-exists? (vendirof (cadr (car plan))))
      ;; Extremely fatal error so we use leave instead of raise.
      (leave (G_ "not enough space in ESP to install bootloader!
 SYSTEM WILL NOT BOOT UNLESS THIS IS FIXED!~%")))
    ;; Some UEFI systems will refuse to acknowledge the existence of boot
    ;; entries unless they're in bootorder, so just shove everything in there.
    (invoke
      efibootmgr "--quiet" "--bootorder"
      ;; Recall efi-bootnums to get a fresh list with new installs.
      (let ((num (cute assoc-ref (efi-bootnums efibootmgr) <>))) ; cute is eager
        (string-join (filter-map (compose num loaderof) plan-files) ",")))))