guix - Wojtek's customized Guix

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2019, 2020, 2023, 2024 Janneke Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2019, 2020 Miguel Ángel Arruga Vivas <rosen644835@gmail.com>
;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2020 Stefan <stefan-guix@vodafonemail.de>
;;; Copyright © 2022 Karl Hallsby <karl@hallsby.com>
;;; Copyright © 2022 Denis 'GNUtoo' Carikli <GNUtoo@cyberdimension.org>
;;; Copyright © 2024 Tomas Volf <~@wolfsden.cz>
;;; Copyright © 2024 Herman Rimm <herman@rimm.ee>
;;;
;;; 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 bootloader grub)
  #:use-module (guix build union)
  #:use-module (guix deprecation)
  #:use-module (guix records)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (guix gexp)
  #:use-module (gnu artwork)
  #:use-module (gnu bootloader)
  #:use-module (gnu build file-systems)
  #:use-module (gnu system uuid)
  #:use-module (gnu system file-systems)
  #:use-module (gnu system keyboard)
  #:use-module (gnu system locale)
  #:use-module (gnu packages bootloaders)
  #:autoload   (gnu packages gtk) (guile-cairo guile-rsvg)
  #:autoload   (gnu packages xorg) (xkeyboard-config)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-2)
  #:use-module (srfi srfi-26)
  #:export (grub-theme
            grub-theme?
            grub-theme-image
            grub-theme-resolution
            grub-theme-color-normal
            grub-theme-color-highlight
            grub-theme-gfxmode

            install-grub-efi-removable
            make-grub-efi-installer
            make-grub-efi-netboot-installer

            grub-bootloader
            grub-efi-bootloader
            grub-efi-removable-bootloader
            grub-efi32-bootloader
            grub-efi-netboot-bootloader
            grub-efi-netboot-removable-bootloader
            grub-mkrescue-bootloader
            grub-minimal-bootloader

            grub-configuration))

;;; Commentary:
;;;
;;; Configuration of GNU GRUB.
;;;
;;; Code:

(define* (normalize-file file mount-point store-directory-prefix)
  "Strip MOUNT-POINT and prepend STORE-DIRECTORY-PREFIX, if any, to FILE, a
G-expression or other lowerable object denoting a file name."

  (define (strip-mount-point mount-point file)
    (if mount-point
        (if (string=? mount-point "/")
            file
            #~(let ((file #$file))
                (if (string-prefix? #$mount-point file)
                    (substring #$file #$(string-length mount-point))
                    file)))
        file))

  (define (prepend-store-directory-prefix store-directory-prefix file)
    (if store-directory-prefix
        #~(string-append #$store-directory-prefix #$file)
        file))

  (prepend-store-directory-prefix store-directory-prefix
                                  (strip-mount-point mount-point file)))



(define-record-type* <grub-theme>
  ;; Default theme contributed by Felipe López.
  grub-theme make-grub-theme
  grub-theme?
  (image           grub-theme-image
                   (default (file-append %artwork-repository
                                         "/grub/GuixSD-fully-black-4-3.svg")))
  (resolution      grub-theme-resolution
                   (default '(1024 . 768)))
  (color-normal    grub-theme-color-normal
                   (default '((fg . light-gray) (bg . black))))
  (color-highlight grub-theme-color-highlight
                   (default '((fg . yellow) (bg . black))))
  (gfxmode         grub-theme-gfxmode
                   (default '("auto"))))          ;list of string


;;;
;;; Background image & themes.
;;;

(define (bootloader-theme config)
  "Return user defined theme in CONFIG if defined or a default theme
otherwise."
  (or (bootloader-configuration-theme config) (grub-theme)))

(define* (image->png image #:key width height)
  "Build a PNG of HEIGHT x WIDTH from IMAGE if its file suffix is \".svg\".
Otherwise the picture in IMAGE is just copied."
  (computed-file "grub-image.png"
                 (with-imported-modules '((gnu build svg))
                   (with-extensions (list guile-rsvg guile-cairo)
                     #~(if (string-suffix? ".svg" #+image)
                           (begin
                             (use-modules (gnu build svg))
                             (svg->png #+image #$output
                                       #:width #$width
                                       #:height #$height))
                           (copy-file #+image #$output))))))

(define* (grub-background-image config)
  "Return the GRUB background image defined in CONFIG or #f if none was found.
If the suffix of the image file is \".svg\", then it is converted into a PNG
file with the resolution provided in CONFIG."
  (let* ((theme (bootloader-theme config))
         (image (grub-theme-image theme)))
    (and image
         (match (grub-theme-resolution theme)
           (((? number? width) . (? number? height))
            (image->png image #:width width #:height height))
           (_ #f)))))

(define (grub-locale-directory grub)
  "Generate a directory with the locales from GRUB."
  (define builder
    #~(begin
        (use-modules (ice-9 ftw))
        (let ((locale (string-append #$grub "/share/locale"))
              (out    #$output))
          (mkdir out)
          (chdir out)
          (for-each (lambda (lang)
                      (let ((file (string-append locale "/" lang
                                                 "/LC_MESSAGES/grub.mo"))
                            (dest (string-append lang ".mo")))
                        (when (file-exists? file)
                          (copy-file file dest))))
                    (scandir locale)))))
  (computed-file "grub-locales" builder))

(define* (eye-candy config store-device store-mount-point
                    #:key st2012-08-29started support for generating source maps (WIP)...plugged in @fitzgen's source-map library
Mihai Bazon