;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2019 Meiyo Peng <meiyo.peng@gmail.com>
;;; Copyright © 2019, 2020 Miguel Ángel Arruga Vivas <rosen644835@gmail.com>
;;; Copyright © 2020 Danny Milosavljevic <dannym@scratchpost.org>
;;; Copyright © 2020, 2021 Brice Waegeneire <brice@waegenei.re>
;;; Copyright © 2020 Florian Pelz <pelzflorian@pelzflorian.de>
;;; Copyright © 2020, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2020, 2023 Janneke Nieuwenhuizen <jannek@gnu.org>
;;; Copyright © 2020, 2022 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
;;; Copyright © 2021 raid5atemyhomework <raid5atemyhomework@protonmail.com>
;;; Copyright © 2023 Bruno Victal <mirai@makinata.eu>
;;; Copyright © 2023 Felix Lechner <felix.lechner@lease-up.com>
;;;
;;; 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 system boot)
  #:use-module (guix gexp)
  #:use-module (guix diagnostics)
  #:use-module (guix i18n)
  #:use-module (guix records)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (gnu bootloader)
  #:use-module (gnu system file-systems)
  #:use-module (gnu system uuid)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (rnrs bytevectors)
  #:export (boot-parameters
            boot-parameters?
            boot-parameters-label
            boot-parameters-root-device
            boot-parameters-bootloader-name
            boot-parameters-bootloader-menu-entries
            boot-parameters-store-crypto-devices
            boot-parameters-store-device
            boot-parameters-store-directory-prefix
            boot-parameters-store-mount-point
            boot-parameters-locale
            boot-parameters-kernel
            boot-parameters-kernel-arguments
            boot-parameters-initrd
            boot-parameters-multiboot-modules
            boot-parameters-version
            %boot-parameters-version

            read-boot-parameters
            read-boot-parameters-file
            bootable-kernel-arguments

            boot-alternative
            boot-alternative?
            boot-alternative-generation
            boot-alternative-system-path
            boot-alternative-epoch
            boot-alternative-parameters

            epoch->date-string
            decorated-boot-label
            boot-parameters->menu-entry
            boot-alternative->menu-entry

            ensure-not-/dev
            system-linux-image-file-name))

;;;
;;; Boot parameters
;;;

;;; Version 1 was introduced early 2022 to mark the departure from long option
;;; names such as '--load' to the more conventional initrd option names like
;;; 'gnu.load'.
;;;
;;; When bumping the boot-parameters version, increment it by one (1).
(define %boot-parameters-version 1)

(define-record-type* <boot-parameters>
  boot-parameters make-boot-parameters boot-parameters?
  (label            boot-parameters-label)
  ;; Because we will use the 'store-device' to create the GRUB search command,
  ;; the 'store-device' has slightly different semantics than 'root-device'.
  ;; The 'store-device' can be a file system uuid, a file system label, or #f,
  ;; but it cannot be a device file name such as "/dev/sda3", since GRUB would
  ;; not understand that.  The 'root-device', on the other hand, corresponds
  ;; exactly to the device field of the <file-system> object representing the
  ;; OS's root file system, so it might be a device file name like
  ;; "/dev/sda3".  The 'store-directory-prefix' field contains #f or the store
  ;; file name inside the 'store-device' as it is seen by GRUB, e.g. it would
  ;; contain "/storefs" if the store is located in that subvolume of a btrfs
  ;; partition.
  (root-device      boot-parameters-root-device)
  (bootloader-name  boot-parameters-bootloader-name)
  (bootloader-menu-entries                        ;list of <menu-entry>
   boot-parameters-bootloader-menu-entries)
  (store-device     boot-parameters-store-device)
  (store-mount-point boot-parameters-store-mount-point)
  (store-directory-prefix boot-parameters-store-directory-prefix)
  (store-crypto-devices boot-parameters-store-crypto-devices
                        (default '()))
  (locale           boot-parameters-locale)
  (kernel           boot-parameters-kernel)
  (kernel-arguments boot-parameters-kernel-arguments)
  (initrd           boot-parameters-initrd)
  (multiboot-modules boot-parameters-multiboot-modules)
  (version          boot-parameters-version  ;positive integer
                    (default %boot-parameters-version)))

(define (read-boot-parameters port)
  "Read boot parameters from PORT and return the corresponding
<boot-parameters> object.  Raise an error if the format is unrecognized."
  (define device-sexp->device
    (match-lambda
      (('uuid (? symbol? type) (? bytevector? bv))
       (bytevector->uuid bv type))
      (('file-system-label (? string? label))
       (file-system-label label))
      ((? bytevector? bv)                         ;old format
       (bytevector->uuid bv 'dce))
      ((? string? device)
       (if (string-contains device ":/")
           device ; nfs-root
           ;; It used to be that we would not distinguish between labels and
           ;; device names.  Try to infer the right thing here.
           (if (string-prefix? "/" device)
               device
               (file-system-label device))))))
  (define uuid-sexp->uuid
    (match-lambda
      (('uuid (? symbol? type) (? bytevector? bv))
       (bytevector->uuid bv type))
      (x
       (warning (G_ "unrecognized uuid ~a at '~a'~%") x (port-filename port))
       #f)))

  ;; New versions are not backward-compatible, so only accept past and current
  ;; versions, not future ones.
  (define (version? n)
    (member n (iota (1+ %boot-parameters-version))))

  (match (read port)
    (('boot-parameters ('version (? version? version))
                       ('label label) ('root-device root)
                       ('kernel kernel)
                       rest ...)
     (boot-parameters
      (version version)
      (label label)
      (root-device (device-sexp->device root))

      (bootloader-name
       (match (assq 'bootloader-name rest)
         ((_ (args ...)) args)
         ((_ args) (list args))
         (#f       'grub))) ; for compatibility reasons.

      (bootloader-menu-entries
       (match (assq 'bootloader-menu-entries rest)
         ((_ entries) (map sexp->menu-entry entries))
         (#f          '())))

      ;; In the past, we would store the directory name of linux instead of
      ;; the absolute file name of its image.  Detect that and correct it.
      (kernel (if (string=? kernel (direct-store-path kernel))
                  (string-append kernel "/"
                                 (system-linux-image-file-name))
                  kernel))

      (kernel-arguments
       (match (assq 'kernel-arguments rest)
         ((_ args) args)
         (#f       '())))                         ;the old format

      (initrd
       (match (assq 'initrd rest)
         (('initrd ('string-append directory file)) ;the old format
          (string-append directory file))
         (('initrd (? string? file))
          file)
         (#f #f)))

      (multiboot-modules
       (match (assq 'multiboot-modules rest)
         ((_ args) args)
         (#f       '())))

      (locale
       (match (assq 'locale rest)
         ((_ locale) locale)
         (#f         #f)))

      (store-device
       ;; Linux device names like "/dev/sda1" are not suitable GRUB device
       ;; identifiers, so we just filter them out.
       (ensure-not-/dev
        (match (assq 'store rest)
          (('store ('device #f) _ ...)
           root-device)
          (('store ('device device) _ ...)
           (device-sexp->device device))
          (_                                      ;the old format
           root-device))))

      (store-directory-prefix
       (match (assq 'store rest)
         (('store . store-data)
          (match (assq 'directory-prefix store-data)
            (('directory-prefix prefix) prefix)
            ;; No directory-prefix found.
            (_ #f)))
         (_
          ;; No store found, old format.
          #f)))

      (store-crypto-devices
       (match (assq 'store rest)
         (('store . store-data)
          (match (assq 'crypto-devices store-data)
            (('crypto-devices (devices ...))
             (map uuid-sexp->uuid devices))
            (('crypto-devices dev)
             (warning (G_ "unrecognized crypto-devices ~S at '~a'~%")
                      dev (port-filename port))
             '())
            (_
             ;; No crypto-devices found.
             '())))
         (_
          ;; No store found, old format.
          '())))

      (store-mount-point
       (match (assq 'store rest)
         (('store ('device _) ('mount-point mount-point) _ ...)
          mount-point)
         (_                                       ;the old format
          "/")))))
    (x                                            ;unsupported format
     (raise
      (make-compound-condition
       (formatted-message
        (G_ "unrecognized boot parameters at '~a'~%")
        (port-filename port))
       (condition
        (&fix-hint (hint (format #f (G_ "This probably means that this version
of Guix is older than the one that created @file{~a}.  To address this, you
need to update Guix:

@example
guix pull
@end example")
                                 (port-filename port))))))))))

(define (read-boot-parameters-file system)
  "Read boot parameters from SYSTEM's (system or generation) \"parameters\"
file and returns the corresponding <boot-parameters> object or #f if the
format is unrecognized.
The object has its kernel-arguments extended in order to make it bootable."
  (let* ((file (string-append system "/parameters"))
         (params (call-with-input-file file read-boot-parameters))
         (root (boot-parameters-root-device params))
         (version (boot-parameters-version params)))
    (boot-parameters
     (inherit params)
     (kernel-arguments (append (bootable-kernel-arguments system root version)
                               (boot-parameters-kernel-arguments params))))))

(define* (bootable-kernel-arguments system root-device version)
  "Return a list of kernel arguments (gexps) to boot SYSTEM from ROOT-DEVICE.
VERSION is the target version of the boot-parameters record."
  ;; If the version is newer than 0, we use the new style initrd parameter
  ;; names, otherwise we use the legacy ones.  This is to maintain backward
  ;; compatibility when producing bootloader configurations for older
  ;; generations.
  (define version>0? (> version 0))
  (let ((root (file-system-device->string root-device
                                          #:uuid-type 'dce)))
    (append
     (if (string=? root "none")
         '() ;  Ignore the case where the root is "none" (typically tmpfs).
         ;; Note: Always use the DCE format because that's what
         ;; (gnu build linux-boot) expects for the 'root'
         ;; kernel command-line option.
         (list (string-append (if version>0? "root=" "--root=") root)))
     (list #~(string-append (if #$version>0? "gnu.system=" "--system=") #$system)
           #~(string-append (if #$version>0? "gnu.load=" "--load=")
                            #$system "/boot")))))

(define-record-type* <boot-alternative>
  boot-alternative make-boot-alternative boot-alternative?
  (generation boot-alternative-generation)
  (system-path boot-alternative-system-path)
  (epoch boot-alternative-epoch)
  (parameters boot-alternative-parameters))

(define (epoch->date-string epoch)
  "Return a string representing the date for EPOCH seconds."
  (let ((time (make-time time-utc 0 epoch)))
    (date->string (time-utc->date time)
                  "~Y-~m-~d ~H:~M")))

(define (decorated-boot-label text generation epoch)
  "Return a string for a nice boot label that includes TEXT, a numbered GENERATION,
and a timestamp derived from EPOCH seconds."
  (let* ((numbered (lambda (number) (string-append "#" (number->string number))))
         (count (and=> generation numbered))
         (timestamp (and=> epoch epoch->date-string))
         (extras (filter identity (list count timestamp)))
         (helpful (if (null? extras)
                      ""
                      (string-append "(" (string-join extras ", ") ")"))))
    (string-join (list text helpful))))

(define (boot-parameters->menu-entry conf)
  "Return a <menu-entry> instance given CONF, a <boot-parameters> instance."
  (let* ((kernel (boot-parameters-kernel conf))
         (multiboot-modules (boot-parameters-multiboot-modules conf))
         (multiboot? (pair? multiboot-modules)))
    (menu-entry
     (label (boot-parameters-label conf))
     (device (boot-parameters-store-device conf))
     (device-mount-point (boot-parameters-store-mount-point conf))
     (device-subvol (boot-parameters-store-directory-prefix conf))
     (linux (and (not multiboot?) kernel))
     (linux-arguments (if (not multiboot?)
                          (boot-parameters-kernel-arguments conf)
                          '()))
     (initrd (boot-parameters-initrd conf))
     (multiboot-kernel (and multiboot? kernel))
     (multiboot-arguments (if multiboot?
                              (boot-parameters-kernel-arguments conf)
                              '()))
     (multiboot-modules (if multiboot?
                            (boot-parameters-multiboot-modules conf)
                            '())))))

(define boot-alternative->menu-entry
  (compose boot-parameters->menu-entry boot-alternative-parameters))

(define (ensure-not-/dev device)
  "If DEVICE starts with a slash, return #f.  This is meant to filter out
Linux device names such as /dev/sda, and to preserve GRUB device names and
file system labels."
  (if (and (string? device) (string-prefix? "/" device))
      #f
      device))

;; XXX: defined here instead of (gnu system) to prevent dependency loop
(define* (system-linux-image-file-name #:optional
                                       (target (or (%current-target-system)
                                                   (%current-system))))
  "Return the basename of the kernel image file for TARGET."
  (cond
   ((string-prefix? "arm" target) "zImage")
   ((string-prefix? "mips" target) "vmlinuz")
   ((string-prefix? "aarch64" target) "Image")
   ((string-prefix? "riscv64" target) "Image")
   (else "bzImage")))

;;; boot.scm ends here