code:
#!/sbin/openrc-run
# GNU Guix --- Functional package management for GNU
# Copyright © 2020 Morgan Smith <Morgan.J.Smith@outlook.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/>.

export GUIX_LOCPATH=@localstatedir@/guix/profiles/per-user/root/guix-profile/lib/locale
export LC_ALL=en_US.utf8
command="@localstatedir@/guix/profiles/per-user/root/current-guix/bin/guix-daemon"
command_args="--build-users-group=guixbuild --discover=no"
command_background="yes"
pidfile="/var/run/guix-daemon.pid"

output_log="/var/log/guix-daemon-stdout.log"
error_log="/var/log/guix-daemon-stderr.log"

repo_name: maximed/guix

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; 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/>.

;;; This file returns a manifest containing release-critical bit, for all the
;;; supported architectures and cross-compilation targets.

(use-modules (gnu packages)
             (guix packages)
             (guix profiles)
             ((gnu ci) #:select (%cross-targets))
             ((gnu services xorg) #:select (%default-xorg-modules))
             (guix utils)
             (srfi srfi-1)
             (srfi srfi-26))

(define* (package->manifest-entry* package system
                                   #:key target)
  "Return a manifest entry for PACKAGE on SYSTEM, optionally cross-compiled to
TARGET."
  (manifest-entry
    (inherit (package->manifest-entry package))
    (name (string-append (package-name package) "." system
                         (if target
                             (string-append "." target)
                             "'")))
    (item (with-parameters ((%current-system system)
                            (%current-target-system target))
            package))))

(define %base-packages
  ;; Packages that must be substitutable on all the platforms Guix supports.
  (map specification->package
       '("bootstrap-tarballs" "gcc-toolchain" "nss-certs"
         "openssh" "emacs" "vim" "python" "guile" "guix")))

(define %base-packages/armhf
  ;; XXX: Relax requirements for armhf-linux for lack of enough build power.
  (map (lambda (package)
         (if (string=? (package-name package) "emacs")
             (specification->package "emacs-no-x")
             package))
       %base-packages))

(define %base-packages/hurd
  ;; XXX: For now we are less demanding of "i586-gnu".
  (map specification->package
       '("coreutils" "grep" "findutils" "gawk" "make"
         "gcc-toolchain" "tar" "xz")))

(define %system-packages
  ;; Key packages proposed by the Guix System installer.
  (append (map specification->package
               '("xorg-server" "xfce" "gnome" "mate" "enlightenment"
                 "openbox" "awesome" "i3-wm" "ratpoison"
                 "emacs" "emacs-exwm" "emacs-desktop-environment"
                 "xlockmore" "slock" "libreoffice"
                 "connman" "network-manager" "network-manager-applet"
                 "openssh" "ntp" "tor"
                 "linux-libre" "grub-hybrid"
                 ;; FIXME: Add IceCat when Rust is available on i686.
                 ;;"icecat"
                 ))
          %default-xorg-modules))

(define %packages-to-cross-build
  ;; Packages that must be cross-buildable from x86_64-linux.
  ;; FIXME: Add (@ (gnu packages gcc) gcc) when <https://bugs.gnu.org/40463>
  ;; is fixed.
  (append (list (@ (gnu packages guile) guile-3.0/fixed))
          (map specification->package
               '("coreutils" "grep" "sed" "findutils" "diffutils" "patch"
                 "gawk" "gettext" "gzip" "xz"
                 "hello" "zlib"))))

(define %packages-to-cross-build-for-mingw
  ;; Many things don't build for MinGW.  Restrict to what's known to work.
  (map specification->package '("hello")))

(define %cross-bootstrap-targets
  ;; Cross-compilation triplets for which 'bootstrap-tarballs' must be
  ;; buildable.
  '("i586-pc-gnu"
    "arm-linux-gnueabihf"
    "aarch64-linux-gnu"))

;;;
;;; Manifests.
;;;

(define %base-manifest
  (manifest
   (append-map (lambda (system)
                 (map (cut package->manifest-entry* <> system)
                      (cond ((string=? system "i586-gnu")
                             %base-packages/hurd)
                            ((string=? system "armhf-linux")
                             ;; FIXME: Drop special case when ci.guix.gnu.org
                             ;; has more ARMv7 build power.
                             %base-packages/armhf)
                            ((string=? system "powerpc64le-linux")
                             ;; FIXME: Drop 'bootstrap-tarballs' until
                             ;; <https://bugs.gnu.org/48055> is fixed.
                             (drop %base-packages 1))
                            (else
                             %base-packages))))
               %cuirass-supported-systems)))

(define %system-manifest
  (manifest
   (append-map (lambda (system)
                 (map (cut package->manifest-entry* <> system)
                      %system-packages))
               '("x86_64-linux" "i686-linux"))))  ;Guix System

(define %cross-manifest
  (manifest
   (append-map (lambda (target)
                 (map (cut package->manifest-entry* <> "x86_64-linux"
                           #:target target)
                      (if (target-mingw? target)
                          %packages-to-cross-build-for-mingw
                          %packages-to-cross-build)))
               ;; XXX: Important bits like libsigsegv and libffi don't support
               ;; RISCV at the moment, so don't require RISCV support.
               (delete "riscv64-linux-gnu" %cross-targets))))

(define %cross-bootstrap-manifest
  (manifest
   (map (lambda (target)
          (package->manifest-entry*
           (specification->package "bootstrap-tarballs")
           "x86_64-linux" #:target target))
        %cross-bootstrap-targets)))

;; Return the union of all three manifests.
(concatenate-manifests (list %base-manifest
                             %system-manifest
                             %cross-manifest
                             %cross-bootstrap-manifest))


code:
# -*- mode: snippet -*-
# name: guix-bzr-reference
# key: bzr-reference...
# --
(bzr-reference
  (url "$1")
  (revision ${2:ref}))


code:
# -*- mode: snippet -*-
# name: guix-cvs-reference
# key: cvs-reference...
# --
(cvs-reference
  (root-directory "${1:root-directory}")
  (module "${2:module}")
  (revision "${3:revision}"))


code:
# -*- mode: snippet -*-
# name: guix-git-reference
# key: git-reference...
# --
(git-reference
  (url "$1")
  (commit ${2:commit}))


code:
# -*- mode: snippet -*-
# name: guix-hg-reference
# key: hg-reference...
# --
(hg-reference
  (url "$1")
  (changeset ${2:changeset}))


code:
# -*- mode: snippet -*-
# name: guix-origin
# key: origin...
# --
(origin
 (method ${1:$$(yas-choose-value "url-fetch"
                                 "url-fetch/tarbomb"
                                 "url-fetch/zipbomb"
                                 "cvs-fetch"
                                 "git-fetch"
                                 "hg-fetch"
                                 "svn-fetch"
                                 "bzr-fetch")})
 (uri ${1:$(cond ((equal yas-text "git-fetch") "git-reference...")
                 ((equal yas-text "svn-fetch") "svn-reference...")
                 ((equal yas-text "hg-fetch")  "hg-reference...")
                 ((equal yas-text "cvs-fetch") "cvs-reference...")
                 ((equal yas-text "bzr-fetch") "bzr-reference...")
                 (t "(string-append \\"https://\\" version \\".tar.gz\\")"))}$0)
 ${1:$(cond ((equal yas-text "git-fetch")
             "(file-name (git-file-name name version))")
            ((equal yas-text "hg-fetch")
             "(file-name (hg-file-name name version))")
            ((member yas-text '("svn-fetch" "cvs-fetch" "bzr-fetch"))
             "(file-name (string-append name \\"-\\" version \\"-checkout\\"))")
            (t ""))}
 (sha256
  (base32
    "$2")))

path: etc/snippets/scheme-mode/guix-origin


code:
# -*- mode: snippet -*-
# name: guix-package
# key: package...
# --
(define-public $1
  (package
    (name "$1")
    (version "$2")
    (source origin...$0)
    (build-system ${3:$$(yas-choose-value "android-ndk-build-system"
                                          "ant-build-system"
                                          "asdf-build-system"
                                          "cargo-build-system"
                                          "clojure-build-system"
                                          "cmake-build-system"
                                          "copy-build-system"
                                          "dub-build-system"
                                          "dune-build-system"
                                          "emacs-build-system"
                                          "font-build-system"
                                          "glib-or-gtk-build-system"
                                          "gnu-build-system"
                                          "go-build-system"
                                          "guile-build-system"
                                          "haskell-build-system"
                                          "julia-build-system"
                                          "linux-module-build-system"
                                          "maven-build-system"
                                          "meson-build-system"
                                          "minify-build-system"
                                          "node-build-system"
                                          "ocaml-build-system"
                                          "perl-build-system"
                                          "python-build-system"
                                          "qt-build-system"
                                          "r-build-system"
                                          "rakudo-build-system"
                                          "ruby-build-system"
                                          "scons-build-system"
                                          "texlive-build-system"
                                          "trivial-build-system"
                                          "waf-build-system")})
    (home-page "$4")
    (synopsis "$5")
    (description "$6")
    (license $7)))

path: etc/snippets/scheme-mode/guix-package


code:
# -*- mode: snippet -*-
# name: guix-svn-reference
# key: svn-reference...
# --
(svn-reference
  (url "$1")
  (revision ${2:svn-revision}))


code:
# -*- mode: snippet -*-
# name: guix-commit-message-add-cl-package
# key: addcl
# condition: git-commit-mode
# --
gnu: Add ${1:`(with-temp-buffer
                (magit-git-wash #'magit-diff-wash-diffs
                  "diff" "--staged")
                (beginning-of-buffer)
                (when (search-forward "+(define-public " nil 'noerror)
                  (replace-regexp-in-string
		   "^sbcl-" ""
		   (thing-at-point 'sexp 'no-properties))))`}.

* `(car (magit-staged-files))` (cl-${1:$(replace-regexp-in-string "^cl-" "" yas-text)}, ecl-$1, sbcl-$1): New variables.


code:
# -*- mode: snippet -*-
# name: guix-commit-message-add-package
# key: add
# condition: git-commit-mode
# --
gnu: Add ${1:`(with-temp-buffer
                (magit-git-wash #'magit-diff-wash-diffs
                  "diff" "--staged")
                (goto-char (point-min))
                (when (re-search-forward "\\+(define-public \\(\\S-+\\)" nil 'noerror)
                  (match-string-no-properties 1)))`}.

* `(car (magit-staged-files))` ($1): New variable.


code:
# -*- mode: snippet -*-
# name: guix-commit-message-rename-package
# key: rename
# condition: git-commit-mode
# --
gnu: ${1:`(with-temp-buffer
           (magit-git-wash #'magit-diff-wash-diffs
             "diff" "--staged")
           (beginning-of-buffer)
           (when (search-forward "-(define-public " nil 'noerror)
             (thing-at-point 'sexp 'no-properties)))`}: Rename package to ${2:`(with-temp-buffer
           (magit-git-wash #'magit-diff-wash-diffs
             "diff" "--staged")
           (beginning-of-buffer)
           (when (search-forward "+(define-public " nil 'noerror)
             (thing-at-point 'sexp 'no-properties)))`}.

* `(car (magit-staged-files))` ($1): Define in terms of
'deprecated-package'.
($2): New variable, formerly known as "$1".


code:
# -*- mode: snippet -*-
# name: guix-commit-message-update-package
# key: update
# condition: git-commit-mode
# --

gnu: ${1:`(with-temp-buffer
           (magit-git-wash #'magit-diff-wash-diffs
             "diff" "--staged")
           (goto-char (point-min))
           (when (re-search-forward "(define-public \\(\\S-+\\)" nil 'noerror)
             (match-string-no-properties 1)))`}: Update to ${2:`(with-temp-buffer
    (magit-git-wash #'magit-diff-wash-diffs
      "diff" "--staged")
    (goto-char (point-min))
    (search-forward "name" nil 'noerror)
    (search-forward "+" nil 'noerror)   ; first change
    (when (and (search-forward "version " nil 'noerror)
               (looking-at-p "\""))
      (let ((end (save-excursion (search-forward "\")" nil 'noerror))))
        (when end
          (forward-char)
          (buffer-substring-no-properties (point) (- end 2))))))`}.

* `(car (magit-staged-files))` ($1): Update to $2.$0
`(mapconcat (lambda (file) (concat "* " file)) (cdr (magit-staged-files)) "\n")`


code:
# -*- mode: snippet -*-
# name: guix-commit-message-use-https-home-page
# key: https
# condition: git-commit-mode
# --
gnu: $1: Use HTTPS home page URI.

* `(car (magit-staged-files))` ($1)[home-page]: Use HTTPS URI.
`(mapconcat (lambda (file) (concat "* " file)) (cdr (magit-staged-files)) "\n")`


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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/>.

(use-modules (gnu tests)
             (gnu packages package-management)
             ((gnu ci) #:select (channel-source->package))
             ((guix git-download) #:select (git-predicate))
             ((guix utils) #:select (current-source-directory))
             (git)
             (ice-9 match))

(define (source-commit directory)
  "Return the commit of the head of DIRECTORY or #f if it could not be
determined."
  (let ((repository #f))
    (catch 'git-error
      (lambda ()
        (set! repository (repository-open directory))
        (let* ((head   (repository-head repository))
               (target (reference-target head))
               (commit (oid->string target)))
          (repository-close! repository)
          commit))
      (lambda _
        (when repository
          (repository-close! repository))
        #f))))

(define (tests-for-current-guix source commit)
  "Return a list of tests for perform, using Guix built from SOURCE, a channel
instance."
  ;; Honor the 'TESTS' environment variable so that one can select a subset
  ;; of tests to run in the usual way:
  ;;
  ;;   make check-system TESTS=installed-os
  (parameterize ((current-guix-package
                  (channel-source->package source #:commit commit)))
    (match (getenv "TESTS")
      (#f
       (all-system-tests))
      ((= string-tokenize (tests ...))
       (filter (lambda (test)
                 (member (system-test-name test) tests))
               (all-system-tests))))))

(define (system-test->manifest-entry test)
  "Return a manifest entry for TEST, a system test."
  (manifest-entry
    (name (string-append "test." (system-test-name test)))
    (version "0")
    (item test)))

(define (system-test-manifest)
  "Return a manifest containing all the system tests, or all those selected by
the 'TESTS' environment variable."
  (define source
    (string-append (current-source-directory) "/.."))

  (define commit
    ;; Fetch the current commit ID so we can potentially build the same
    ;; derivation as ci.guix.gnu.org.
    (source-commit source))

  ;; Intern SOURCE so that 'build-from-source' in (guix channels) sees
  ;; "fresh" file names and thus doesn't find itself loading .go files
  ;; from ~/.cache/guile when it loads 'build-aux/build-self.scm'.
  (let* ((source (local-file source
                             (if commit
                                 (string-append "guix-"
                                                (string-take commit 7))
                                 "guix-source")
                             #:recursive? #t
                             #:select?
                             (or (git-predicate source)
                                 (const #t))))
         (tests  (tests-for-current-guix source commit)))
    (format (current-error-port) "Selected ~a system tests...~%"
            (length tests))

    (manifest (map system-test->manifest-entry tests))))

;; Return the manifest.
(system-test-manifest)


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Joshua S. Grant <jgrant@parenthetical.io>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.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)
  #:use-module (guix i18n)
  #:use-module (guix diagnostics)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (ice-9 match)
  #:use-module (guix packages)
  #:use-module (gnu packages)
  #:use-module (gnu services)
  #:export (use-package-modules
            use-service-modules
            use-system-modules))

;;; Commentary:
;;;
;;; This composite module re-exports core parts the (gnu …) public modules.
;;;
;;; Code:

(eval-when (eval load compile)
  (begin
    (define %public-modules
      '((gnu system)
        (gnu system mapped-devices)
        (gnu system file-systems)
        (gnu bootloader)
        (gnu bootloader grub)
        (gnu system keyboard)
        (gnu system pam)
        (gnu system shadow)                       ; 'user-account'
        (gnu system linux-initrd)
        (gnu system nss)
        (gnu services)
        (gnu services base)
        (gnu packages)
        (gnu packages base)
        (guix gexp)))                             ; so gexps can be used

    (for-each (let ((i (module-public-interface (current-module))))
                (lambda (m)
                  (module-use! i (resolve-interface m))))
              %public-modules)))

(define (%try-use-modules modules location make-hint)
  "Attempt to load all of MODULES.  Report errors as coming from LOCATION, a
<location> record, and use MAKE-HINT to produce a fix hint."
  (define (location->string loc)
    (match loc
      (#f "")
      (($ <location> file line column)
       (format #f "~a:~a:~a: " file line column))))

  (for-each (lambda (module)
              (catch 'misc-error
                (lambda ()
                  (process-use-modules `((,module))))
                (lambda _
                  (raise
                   (apply
                    make-compound-condition
                    (formatted-message (G_ "module ~a not found")
                                       module)
                    (condition
                     (&error-location (location location)))
                    (or (and=> (make-hint module) list)
                        '()))))))
            modules))

(define (package-module-hint module)
  (define last-name
    (match module
      ((_ ... last)
       (symbol->string last))))

  (match (find-packages-by-name last-name)
    (()
     (condition
      (&fix-hint
       (hint (G_ "\
You may use @command{guix package --show=foo | grep location} to search
for the location of package @code{foo}.
If you get the line @code{location: gnu/packages/bar.scm:174:2},
add @code{bar} to the @code{use-package-modules} form.")))))
    ((package _ ...)
     (condition
      (&fix-hint
       (hint (format #f (G_ "\
Try adding @code{(use-package-modules ~a)}.")
                     (basename (location-file (package-location package))
                               ".scm"))))))))

(define (service-module-hint module)
  (define last-name
    (match module
      ((_ ... last)
       last)))

  (match (lookup-service-types last-name)
    (()
     (condition
      (&fix-hint
       (hint (format #f (G_ "\
You may use @command{guix system search ~a} to search for a service
matching @code{~a}.
If you get the line @code{location: gnu/services/foo.scm:188:2},
add @code{foo} to the @code{use-service-modules} form.")
                     last-name last-name)))))
    ((package _ ...)
     (condition
      (&fix-hint
       (hint (format #f (G_ "\
Try adding @code{(use-service-modules ~a)}.")
                     (basename (location-file (service-type-location package))
                               ".scm"))))))))

(define-syntax-rule (try-use-modules hint modules ...)
  (eval-when (expand load eval)
    (%try-use-modules '(modules ...)
                      (source-properties->location
                       (current-source-location))
                      hint)))

(define-syntax-rule (use-package-modules module ...)
  (try-use-modules package-module-hint
                   (gnu packages module) ...))

(define-syntax-rule (use-service-modules module ...)
  (try-use-modules service-module-hint
                   (gnu services module) ...))

(define-syntax-rule (use-system-modules module ...)
  (try-use-modules (const #f)                     ;no hint
                   (gnu system module) ...))

;;; gnu.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
;;;
;;; 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 artwork)
  #:use-module (guix packages)
  #:use-module (guix git-download)
  #:export (%artwork-repository))

;;; Commentary:
;;;
;;; Common place for the definition of the Guix artwork repository.
;;;
;;; Code:

(define %artwork-repository
  (let ((commit "2f2fe74c1078be605a6a93c2193fd6c715cebbb0"))
    (origin
      (method git-fetch)
      (uri (git-reference
             (url "https://git.savannah.gnu.org/git/guix/guix-artwork.git")
             (commit commit)))
      (file-name (string-append "guix-artwork-" (string-take commit 7)
                                "-checkout"))
      (sha256
       (base32
        "0c8r0phvm3wgf914n2kw1461cwdjl2zbzqvzq9x7d9pwkgv7xmq7")))))

;;; artwork.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 David Craven <david@craven.ch>
;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; 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)
  #:use-module (guix discovery)
  #:use-module (guix gexp)
  #:use-module (guix profiles)
  #:use-module (guix records)
  #:use-module (guix ui)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:export (menu-entry
            menu-entry?
            menu-entry-label
            menu-entry-device
            menu-entry-linux
            menu-entry-linux-arguments
            menu-entry-initrd
            menu-entry-device-mount-point
            menu-entry-multiboot-kernel
            menu-entry-multiboot-arguments
            menu-entry-multiboot-modules

            menu-entry->sexp
            sexp->menu-entry

            bootloader
            bootloader?
            bootloader-name
            bootloader-package
            bootloader-installer
            bootloader-disk-image-installer
            bootloader-configuration-file
            bootloader-configuration-file-generator

            bootloader-configuration
            bootloader-configuration?
            bootloader-configuration-bootloader
            bootloader-configuration-target
            bootloader-configuration-menu-entries
            bootloader-configuration-default-entry
            bootloader-configuration-timeout
            bootloader-configuration-keyboard-layout
            bootloader-configuration-theme
            bootloader-configuration-terminal-outputs
            bootloader-configuration-terminal-inputs
            bootloader-configuration-serial-unit
            bootloader-configuration-serial-speed
            bootloader-configuration-additional-configuration

            %bootloaders
            lookup-bootloader-by-name

            efi-bootloader-chain))

;;;
;;; Menu-entry record.
;;;

(define-record-type* <menu-entry>
  menu-entry make-menu-entry
  menu-entry?
  (label           menu-entry-label)
  (device          menu-entry-device       ; file system uuid, label, or #f
                   (default #f))
  (device-mount-point menu-entry-device-mount-point
                   (default #f))
  (linux           menu-entry-linux
                   (default #f))
  (linux-arguments menu-entry-linux-arguments
                   (default '()))          ; list of string-valued gexps
  (initrd          menu-entry-initrd       ; file name of the initrd as a gexp
                   (default #f))
  (multiboot-kernel menu-entry-multiboot-kernel
                    (default #f))
  (multiboot-arguments menu-entry-multiboot-arguments
                       (default '()))      ; list of string-valued gexps
  (multiboot-modules menu-entry-multiboot-modules
                     (default '())))       ; list of multiboot commands, where
                                           ; a command is a list of <string>

(define (menu-entry->sexp entry)
  "Return ENTRY serialized as an sexp."
  (match entry
    (($ <menu-entry> label device mount-point linux linux-arguments initrd #f
                     ())
     `(menu-entry (version 0)
                  (label ,label)
                  (device ,device)
                  (device-mount-point ,mount-point)
                  (linux ,linux)
                  (linux-arguments ,linux-arguments)
                  (initrd ,initrd)))
    (($ <menu-entry> label device mount-point #f () #f
                     multiboot-kernel multiboot-arguments multiboot-modules)
     `(menu-entry (version 0)
                  (label ,label)
                  (device ,device)
                  (device-mount-point ,mount-point)
                  (multiboot-kernel ,multiboot-kernel)
                  (multiboot-arguments ,multiboot-arguments)
                  (multiboot-modules ,multiboot-modules)))))

(define (sexp->menu-entry sexp)
  "Turn SEXP, an sexp as returned by 'menu-entry->sexp', into a <menu-entry>
record."
  (match sexp
    (('menu-entry ('version 0)
                  ('label label) ('device device)
                  ('device-mount-point mount-point)
                  ('linux linux) ('linux-arguments linux-arguments)
                  ('initrd initrd) _ ...)
     (menu-entry
      (label label)
      (device device)
      (device-mount-point mount-point)
      (linux linux)
      (linux-arguments linux-arguments)
      (initrd initrd)))
    (('menu-entry ('version 0)
                  ('label label) ('device device)
                  ('device-mount-point mount-point)
                  ('multiboot-kernel multiboot-kernel)
                  ('multiboot-arguments multiboot-arguments)
                  ('multiboot-modules multiboot-modules) _ ...)
     (menu-entry
      (label label)
      (device device)
      (device-mount-point mount-point)
      (multiboot-kernel multiboot-kernel)
      (multiboot-arguments multiboot-arguments)
      (multiboot-modules multiboot-modules)))))

;;;
;;; Bootloader record.
;;;

;; The <bootloader> record contains fields expressing how the bootloader
;; should be installed. Every bootloader in gnu/bootloader/ directory
;; has to be described by this record.

(define-record-type* <bootloader>
  bootloader make-bootloader
  bootloader?
  (name                            bootloader-name)
  (package                         bootloader-package)
  (installer                       bootloader-installer)
  (disk-image-installer            bootloader-disk-image-installer
                                   (default #f))
  (configuration-file              bootloader-configuration-file)
  (configuration-file-generator    bootloader-configuration-file-generator))

;;;
;;; Bootloader configuration record.
;;;

;; The <bootloader-configuration> record contains bootloader independant
;; configuration used to fill bootloader configuration file.

(define-record-type* <bootloader-configuration>
  bootloader-configuration make-bootloader-configuration
  bootloader-configuration?
  (bootloader         bootloader-configuration-bootloader) ;<bootloader>
  (target             bootloader-configuration-target      ;string
                      (default #f))
  (menu-entries       bootloader-configuration-menu-entries ;list of <menu-entry>
                      (default '()))
  (default-entry      bootloader-configuration-default-entry ;integer
                      (default 0))
  (timeout            bootloader-configuration-timeout ;seconds as integer
                      (default 5))
  (keyboard-layout    bootloader-configuration-keyboard-layout ;<keyboard-layout> | #f
                      (default #f))
  (theme              bootloader-configuration-theme ;bootloader-specific theme
                      (default #f))
  (terminal-outputs   bootloader-configuration-terminal-outputs ;list of symbols
                      (default '(gfxterm)))
  (terminal-inputs    bootloader-configuration-terminal-inputs ;list of symbols
                      (default '()))
  (serial-unit        bootloader-configuration-serial-unit ;integer | #f
                      (default #f))
  (serial-speed       bootloader-configuration-serial-speed ;integer | #f
                      (default #f)))

;;;
;;; Bootloaders.
;;;

(define (bootloader-modules)
  "Return the list of bootloader modules."
  (all-modules (map (lambda (entry)
                      `(,entry . "gnu/bootloader"))
                    %load-path)
               #:warn warn-about-load-error))

(define %bootloaders
  ;; The list of publically-known bootloaders.
  (delay (fold-module-public-variables (lambda (obj result)
                                         (if (bootloader? obj)
                                             (cons obj result)
                                             result))
                                       '()
                                       (bootloader-modules))))

(define (lookup-bootloader-by-name name)
  "Return the bootloader called NAME."
  (or (find (lambda (bootloader)
              (eq? name (bootloader-name bootloader)))
            (force %bootloaders))
      (leave (G_ "~a: no such bootloader~%") name)))

(define (efi-bootloader-profile files bootloader-package hooks)
  "Creates a profile with BOOTLOADER-PACKAGE and a directory collection/ with
links to additional FILES from the store.  This collection is meant to be used
by the bootloader installer.

FILES is a list of file or directory names from the store, which will be
symlinked into the collection/ directory.  If a directory name ends with '/',
then the directory content instead of the directory itself will be symlinked
into the collection/ directory.

FILES may contain file like objects produced by functions like plain-file,
local-file, etc., or package contents produced with file-append.

HOOKS lists additional hook functions to modify the profile."
  (define (bootloader-collection manifest)
    (define build
        (with-imported-modules '((guix build utils)
                                 (ice-9 ftw)
                                 (srfi srfi-1)
                                 (srfi srfi-26))
          #~(begin
            (use-modules ((guix build utils)
                          #:select (mkdir-p strip-store-file-name))
                         ((ice-9 ftw)
                          #:select (scandir))
                         ((srfi srfi-1)
                          #:select (append-map every remove))
                         ((srfi srfi-26)
                          #:select (cut)))
            (define (symlink-to file directory transform)
              "Creates a symlink to FILE named (TRANSFORM FILE) in DIRECTORY."
              (symlink file (string-append directory "/" (transform file))))
            (define (directory-content directory)
              "Creates a list of absolute path names inside DIRECTORY."
              (map (lambda (name)
                     (string-append directory name))
                   (or (scandir directory (lambda (name)
                                            (not (member name '("." "..")))))
                       '())))
            (define name-ends-with-/? (cut string-suffix? "/" <>))
            (define (name-is-store-entry? name)
              "Return #t if NAME is a direct store entry and nothing inside."
              (not (string-index (strip-store-file-name name) #\/)))
            (let* ((collection (string-append #$output "/collection"))
                   (files '#$files)
                   (directories (filter name-ends-with-/? files))
                   (names-from-directories
                    (append-map (lambda (directory)
                                  (directory-content directory))
                                directories))
                   (names (append names-from-directories
                                  (remove name-ends-with-/? files))))
              (mkdir-p collection)
              (if (every file-exists? names)
                  (begin
                    (for-each (lambda (name)
                               (symlink-to name collection
                                            (if (name-is-store-entry? name)
                                                strip-store-file-name
                                                basename)))
                              names)
                    #t)
                  #f)))))

    (gexp->derivation "bootloader-collection"
                      build
                      #:local-build? #t
                      #:substitutable? #f
                      #:properties
                      `((type . profile-hook)
                        (hook . bootloader-collection))))

  (profile (content (packages->manifest (list bootloader-package)))
           (name "bootloader-profile")
           (hooks (append (list bootloader-collection) hooks))
           (locales? #f)
           (allow-collisions? #f)
           (relative-symlinks? #f)))

(define* (efi-bootloader-chain files
                               final-bootloader
                               #:key
                               (hooks '())
                               installer)
  "Define a bootloader chain with FINAL-BOOTLOADER as the final bootloader and
certain directories and files from the store given in the list of FILES.

FILES may contain file like objects produced by functions like plain-file,
local-file, etc., or package contents produced with file-append.  They will be
collected inside a directory collection/ inside a generated bootloader profile,
which will be passed to the INSTALLER.

If a directory name in FILES ends with '/', then the directory content instead
of the directory itself will be symlinked into the collection/ directory.

The procedures in the HOOKS list can be used to further modify the bootloader
profile.  It is possible to pass a single function instead of a list.

If the INSTALLER argument is used, then this function will be called to install
the bootloader.  Otherwise the installer of the FINAL-BOOTLOADER will be called."
  (let* ((final-installer (or installer
                              (bootloader-installer final-bootloader)))
         (profile (efi-bootloader-profile files
                                          (bootloader-package final-bootloader)
                                          (if (list? hooks)
                                              hooks
                                              (list hooks)))))
    (bootloader
     (inherit final-bootloader)
     (package profile)
     (installer
      #~(lambda (bootloader target mount-point)
          (#$final-installer bootloader target mount-point)
          (copy-recursively
           (string-append bootloader "/collection")
           (string-append mount-point target)
           #:follow-symlinks? #t
           #:log (%make-void-port "w")))))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Timothy Sample <samplet@ngyro.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 bootloader depthcharge)
  #:use-module (gnu bootloader extlinux)
  #:use-module (gnu bootloader)
  #:use-module (gnu packages bootloaders)
  #:use-module (guix gexp)
  #:use-module (guix utils)
  #:use-module (ice-9 match)
  #:export (depthcharge-bootloader))

(define (signed-kernel kernel kernel-arguments initrd)
  (define builder
    (with-imported-modules '((guix build utils))
      #~(begin
          (use-modules (guix build utils)
                       (ice-9 binary-ports)
                       (rnrs bytevectors))
          (set-path-environment-variable "PATH" '("bin") (list #$dtc))

          ;; TODO: These files have to be writable, so we copy them.
          ;; This can probably be fixed by using a ".its" file, just
          ;; be careful not to break initrd loading.
          (copy-file #$kernel "zImage")
          (chmod "zImage" #o755)
          (copy-file (string-append (dirname #$kernel) "/lib/dtbs/"
                                    "rk3288-veyron-speedy.dtb")
                     "rk3288-veyron-speedy.dtb")
          (chmod "rk3288-veyron-speedy.dtb" #o644)
          (copy-file #$initrd "initrd")
          (chmod "initrd" #o644)

          (invoke (string-append #$u-boot-tools "/bin/mkimage")
                  "-D" "-I dts -O dtb -p 2048"
		  "-f" "auto"
                  "-A" "arm"
                  "-O" "linux"
                  "-T" "kernel"
                  "-C" "None"
                  "-d" "zImage"
                  "-a" "0"
                  "-b" "rk3288-veyron-speedy.dtb"
                  "-i" "initrd"
	          "image.itb")
          (call-with-output-file "bootloader.bin"
            (lambda (port)
              (put-bytevector port (make-bytevector 512 0))))
          (with-output-to-file "kernel-arguments"
	    (lambda ()
	      (display (string-join (list #$@kernel-arguments)))))
          (invoke (string-append #$vboot-utils "/bin/vbutil_kernel")
                  "--pack" #$output
                  "--version" "1"
                  "--vmlinuz" "image.itb"
		  "--arch" "arm"
		  "--keyblock" (string-append #$vboot-utils
                                              "/share/vboot-utils/devkeys/"
                                              "kernel.keyblock")
		  "--signprivate" (string-append #$vboot-utils
                                                 "/share/vboot-utils/devkeys/"
                                                 "kernel_data_key.vbprivk")
                  "--config" "kernel-arguments"
                  "--bootloader" "bootloader.bin"))))
  (computed-file "vmlinux.kpart" builder))

(define* (depthcharge-configuration-file config entries
                                         #:key
                                         (system (%current-system))
                                         (old-entries '())
                                         #:allow-other-keys)
  (match entries
    ((entry)
     (let ((kernel (menu-entry-linux entry))
           (kernel-arguments (menu-entry-linux-arguments entry))
           (initrd (menu-entry-initrd entry)))
       ;; XXX: Make this a symlink.
       (signed-kernel kernel kernel-arguments initrd)))
    (_ (error "Too many bootloader menu entries!"))))

(define install-depthcharge
  #~(lambda (bootloader device mount-point)
      (let ((kpart (string-append mount-point
                                  "/boot/depthcharge/vmlinux.kpart")))
        (write-file-on-device kpart (stat:size (stat kpart)) device 0))))

(define depthcharge-bootloader
  (bootloader
   (name 'depthcharge)
   (package #f)
   (installer install-depthcharge)
   (configuration-file "/boot/depthcharge/vmlinux.kpart")
   (configuration-file-generator depthcharge-configuration-file)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 David Craven <david@craven.ch>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.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 bootloader extlinux)
  #:use-module (gnu bootloader)
  #:use-module (gnu packages bootloaders)
  #:use-module (guix gexp)
  #:use-module (guix utils)
  #:export (extlinux-bootloader
            extlinux-bootloader-gpt))

(define* (extlinux-configuration-file config entries
                                      #:key
                                      (system (%current-system))
                                      (old-entries '())
                                      #:allow-other-keys)
  "Return the U-Boot configuration file corresponding to CONFIG, a
<u-boot-configuration> object, and where the store is available at STORE-FS, a
<file-system> object.  OLD-ENTRIES is taken to be a list of menu entries
corresponding to old generations of the system."

  (define all-entries
    (append entries (bootloader-configuration-menu-entries config)))

  (define (menu-entry->gexp entry)
    (let ((label (menu-entry-label entry))
          (kernel (menu-entry-linux entry))
          (kernel-arguments (menu-entry-linux-arguments entry))
          (initrd (menu-entry-initrd entry)))
      #~(format port "LABEL ~a
  MENU LABEL ~a
  KERNEL ~a
  FDTDIR ~a/lib/dtbs
  INITRD ~a
  APPEND ~a
~%"
                #$label #$label
                #$kernel (dirname #$kernel) #$initrd
                (string-join (list #$@kernel-arguments)))))

  (define builder
    #~(call-with-output-file #$output
        (lambda (port)
          (let ((timeout #$(bootloader-configuration-timeout config)))
            (format port "# This file was generated from your Guix configuration.  Any changes
# will be lost upon reconfiguration.
UI menu.c32
MENU TITLE GNU Guix Boot Options
PROMPT ~a
TIMEOUT ~a~%"
                    (if (> timeout 0) 1 0)
                    ;; timeout is expressed in 1/10s of seconds.
                    (* 10 timeout))
            #$@(map menu-entry->gexp all-entries)

            #$@(if (pair? old-entries)
                   #~((format port "~%")
                      #$@(map menu-entry->gexp old-entries)
                      (format port "~%"))
                   #~())))))

  (computed-file "extlinux.conf" builder
                 #:options '(#:local-build? #t
                             #:substitutable? #f)))

;;;
;;; Install procedures.
;;;

(define (install-extlinux mbr)
  #~(lambda (bootloader device mount-point)
      (let ((extlinux (string-append bootloader "/sbin/extlinux"))
            (install-dir (string-append mount-point "/boot/extlinux"))
            (syslinux-dir (string-append bootloader "/share/syslinux")))
        (for-each (lambda (file)
                    (install-file file install-dir))
                  (find-files syslinux-dir "\\.c32$"))
        (invoke/quiet extlinux "--install" install-dir)
        (write-file-on-device (string-append syslinux-dir "/" #$mbr)
                              440 device 0))))

(define install-extlinux-mbr
  (install-extlinux "mbr.bin"))

(define install-extlinux-gpt
  (install-extlinux "gptmbr.bin"))

;;;
;;; Bootloader definitions.
;;;

(define extlinux-bootloader
  (bootloader
   (name 'extlinux)
   (package syslinux)
   (installer install-extlinux-mbr)
   (configuration-file "/boot/extlinux/extlinux.conf")
   (configuration-file-generator extlinux-configuration-file)))

(define extlinux-bootloader-gpt
  (bootloader
   (inherit extlinux-bootloader)
   (installer install-extlinux-gpt)))


code:
;;; 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 Jan (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>
;;;
;;; 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 records)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (guix gexp)
  #:use-module (gnu artwork)
  #:use-module (gnu bootloader)
  #: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)
  #: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-netboot

            grub-bootloader
            grub-efi-bootloader
            grub-efi-netboot-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 store-directory-prefix port)
  "Return a gexp that writes to PORT (a port-valued gexp) the 'grub.cfg' part
concerned with graphics mode, background images, colors, and all that.
STORE-DEVICE designates the device holding the store, and STORE-MOUNT-POINT is
its mount point; these are used to determine where the background image and
fonts must be searched for.  STORE-DIRECTORY-PREFIX is a directory prefix to
prepend to any store file name."
  (define (setup-gfxterm config)
    (if (memq 'gfxterm (bootloader-configuration-terminal-outputs config))
        #~(format #f "
if loadfont unicode; then
  set gfxmode=~a
  insmod all_video
  insmod gfxterm
fi~%"
                  #$(string-join
                     (grub-theme-gfxmode (bootloader-theme config))
                     ";"))
        ""))

  (define (theme-colors type)
    (let* ((theme  (bootloader-theme config))
           (colors (type theme)))
      (string-append (symbol->string (assoc-ref colors 'fg)) "/"
                     (symbol->string (assoc-ref colors 'bg)))))

  (define image
    (normalize-file (grub-background-image config)
                    store-mount-point
                    store-directory-prefix))

  (and image
       #~(format #$port "
# Set 'root' to the partition that contains /gnu/store.
~a

~a
~a

insmod png
if background_image ~a; then
  set color_normal=~a
  set color_highlight=~a
else
  set menu_color_normal=cyan/blue
  set menu_color_highlight=white/blue
fi~%"
                 #$(grub-root-search store-device image)
                 #$(setup-gfxterm config)
                 #$(grub-setup-io config)

                 #$image
                 #$(theme-colors grub-theme-color-normal)
                 #$(theme-colors grub-theme-color-highlight))))

;;;
;;; Configuration file.
;;;

(define* (keyboard-layout-file layout
                               #:key
                               (grub grub))
  "Process the X keyboard layout description LAYOUT, a <keyboard-layout> record,
and return a file in the format for GRUB keymaps.  LAYOUT must be present in
the 'share/X11/xkb/symbols/' directory of 'xkeyboard-config'."
  (define builder
    (with-imported-modules '((guix build utils))
      #~(begin
          (use-modules (guix build utils))

          ;; 'grub-kbdcomp' passes all its arguments but '-o' to 'ckbcomp'
          ;; (from the 'console-setup' package).
          (invoke #+(file-append grub "/bin/grub-mklayout")
                  "-i" #+(keyboard-layout->console-keymap layout)
                  "-o" #$output))))

  (computed-file (string-append "grub-keymap."
                                (string-map (match-lambda
                                              (#\, #\-)
                                              (chr chr))
                                            (keyboard-layout-name layout)))
                 builder))

(define (grub-setup-io config)
  "Return GRUB commands to configure the input / output interfaces.  The result
is a string that can be inserted in grub.cfg."
  (let* ((symbols->string (lambda (list)
                           (string-join (map symbol->string list) " ")))
         (outputs (bootloader-configuration-terminal-outputs config))
         (inputs (bootloader-configuration-terminal-inputs config))
         (unit (bootloader-configuration-serial-unit config))
         (speed (bootloader-configuration-serial-speed config))

         ;; Respectively, GRUB_TERMINAL_OUTPUT and GRUB_TERMINAL_INPUT,
         ;; as documented in GRUB manual section "Simple Configuration
         ;; Handling".
         (valid-outputs '(console serial serial_0 serial_1 serial_2 serial_3
                          gfxterm vga_text mda_text morse spkmodem))
         (valid-inputs '(console serial serial_0 serial_1 serial_2 serial_3
                         at_keyboard usb_keyboard))

         (io (string-append
               "terminal_output "
               (symbols->string
                 (map
                   (lambda (output)
                     (if (memq output valid-outputs) output #f)) outputs)) "\n"
               (if (null? inputs)
                 ""
                 (string-append
                   "terminal_input "
                   (symbols->string
                     (map
                       (lambda (input)
                         (if (memq input valid-inputs) input #f)) inputs)) "\n"))
               ;; UNIT and SPEED are arguments to the same GRUB command
               ;; ("serial"), so we process them together.
               (if (or unit speed)
                 (string-append
                   "serial"
                   (if unit
                     ;; COM ports 1 through 4
                     (if (and (exact-integer? unit) (<= unit 3) (>= unit 0))
                       (string-append " --unit=" (number->string unit))
                       #f)
                     "")
                   (if speed
                     (if (exact-integer? speed)
                       (string-append " --speed=" (number->string speed))
                       #f)
                     ""))
                 ""))))
    (format #f "~a" io)))

(define (grub-root-search device file)
  "Return the GRUB 'search' command to look for DEVICE, which contains FILE,
a gexp.  The result is a gexp that can be inserted in the grub.cfg-generation
code."
  ;; Usually FILE is a file name gexp like "/gnu/store/…-linux/vmlinuz", but
  ;; it can also be something like "(hd0,msdos1)/vmlinuz" in the case of
  ;; custom menu entries.  In the latter case, don't emit a 'search' command.
  (if (and (string? file) (not (string-prefix? "/" file)))
      ""
      (match device
        ;; Preferably refer to DEVICE by its UUID or label.  This is more
        ;; efficient and less ambiguous, see <http://bugs.gnu.org/22281>.
        ((? uuid? uuid)
         (format #f "search --fs-uuid --set ~a"
                 (uuid->string device)))
        ((? file-system-label? label)
         (format #f "search --label --set ~a"
                 (file-system-label->string label)))
        ((? (lambda (device)
              (and (string? device) (string-contains device ":/"))) nfs-uri)
         ;; If the device is an NFS share, then we assume that the expected
         ;; file on that device (e.g. the GRUB background image or the kernel)
         ;; has to be loaded over the network.  Otherwise we would need an
         ;; additional device information for some local disk to look for that
         ;; file, which we do not have.
         ;;
         ;; We explicitly set "root=(tftp)" here even though if grub.cfg
         ;; had been loaded via TFTP, Grub would have set "root=(tftp)"
         ;; automatically anyway.  The reason is if you have a system that
         ;; used to be on NFS but now is local, root would be set to local
         ;; disk.  If you then selected an older system generation that is
         ;; supposed to boot from network in the Grub boot menu, Grub still
         ;; wouldn't load those files from network otherwise.
         ;;
         ;; TFTP is preferred to HTTP because it is used more widely and
         ;; specified in standards more widely--especially BOOTP/DHCPv4
         ;; defines a TFTP server for DHCP option 66, but not HTTP.
         ;;
         ;; Note: DHCPv6 specifies option 59 to contain a boot-file-url,
         ;; which can contain a HTTP or TFTP URL.
         ;;
         ;; Note: It is assumed that the file paths are of a similar
         ;; setup on both the TFTP server and the NFS server (it is
         ;; not possible to search for files on TFTP).
         ;;
         ;; TODO: Allow HTTP.
         "set root=(tftp)")
        ((or #f (? string?))
         #~(format #f "search --file --set ~a" #$file)))))

(define* (grub-configuration-file config entries
                                  #:key
                                  (locale #f)
                                  (system (%current-system))
                                  (old-entries '())
                                  (store-crypto-devices '())
                                  store-directory-prefix)
  "Return the GRUB configuration file corresponding to CONFIG, a
<bootloader-configuration> object, and where the store is available at
STORE-FS, a <file-system> object.  OLD-ENTRIES is taken to be a list of menu
entries corresponding to old generations of the system.
STORE-CRYPTO-DEVICES contain the UUIDs of the encrypted units that must
be unlocked to access the store contents.
STORE-DIRECTORY-PREFIX may be used to specify a store prefix, as is required
when booting a root file system on a Btrfs subvolume."
  (define all-entries
    (append entries (bootloader-configuration-menu-entries config)))
  (define (menu-entry->gexp entry)
    (let ((label (menu-entry-label entry))
          (linux (menu-entry-linux entry))
          (device (menu-entry-device entry))
          (device-mount-point (menu-entry-device-mount-point entry)))
      (if linux
          (let ((arguments (menu-entry-linux-arguments entry))
                (linux (normalize-file linux
                                       device-mount-point
                                       store-directory-prefix))
                (initrd (normalize-file (menu-entry-initrd entry)
                                        device-mount-point
                                        store-directory-prefix)))
         ;; Here DEVICE is the store and DEVICE-MOUNT-POINT is its mount point.
         ;; Use the right file names for LINUX and INITRD in case
         ;; DEVICE-MOUNT-POINT is not "/", meaning that the store is on a
         ;; separate partition.

         ;; When BTRFS-SUBVOLUME-FILE-NAME is defined, prepend it the linux and
         ;; initrd paths, to allow booting from a Btrfs subvolume.
         #~(format port "menuentry ~s {
  ~a
  linux ~a ~a
  initrd ~a
}~%"
                   #$label
                   #$(grub-root-search device linux)
                   #$linux (string-join (list #$@arguments))
                   #$initrd))
          (let ((kernel (menu-entry-multiboot-kernel entry))
                (arguments (menu-entry-multiboot-arguments entry))
                (modules (menu-entry-multiboot-modules entry))
                (root-index 1))            ; XXX EFI will need root-index 2
        #~(format port "
menuentry ~s {
  multiboot ~a root=device:hd0s~a~a~a
}~%"
                  #$label
                  #$kernel
                  #$root-index (string-join (list #$@arguments) " " 'prefix)
                  (string-join (map string-join '#$modules)
                               "\n  module " 'prefix))))))

  (define (crypto-devices)
    (define (crypto-device->cryptomount dev)
      (if (uuid? dev)
          #~(format port "cryptomount -u ~a~%"
                    ;; cryptomount only accepts UUID without the hypen.
                    #$(string-delete #\- (uuid->string dev)))
          ;; Other type of devices aren't implemented.
          #~()))
    (let ((devices (map crypto-device->cryptomount store-crypto-devices))
          ;; XXX: Add luks2 when grub 2.06 is packaged.
          (modules #~(format port "insmod luks~%")))
      (if (null? devices)
          devices
          (cons modules devices))))

  (define (sugar)
    (let* ((entry (first all-entries))
           (device (menu-entry-device entry))
           (mount-point (menu-entry-device-mount-point entry)))
      (eye-candy config
                 device
                 mount-point
                 #:store-directory-prefix store-directory-prefix
                 #:port #~port)))

  (define locale-config
    (let* ((entry (first all-entries))
           (device (menu-entry-device entry))
           (mount-point (menu-entry-device-mount-point entry))
           (bootloader (bootloader-configuration-bootloader config))
           (grub (bootloader-package bootloader)))
      #~(let ((locale #$(and locale
                             (locale-definition-source
                              (locale-name->definition locale))))
              (locales #$(and locale
                              (normalize-file (grub-locale-directory grub)
                                              mount-point
                                              store-directory-prefix))))
          (when locale
            (format port "\
# Localization configuration.
~asearch --file --set ~a/en@quot.mo
set locale_dir=~a
set lang=~a~%"
                    ;; Skip the search if there is an image, as it has already
                    ;; been performed by eye-candy and traversing the store is
                    ;; an expensive operation.
                    #$(if (grub-theme-image (bootloader-theme config))
                          "# "
                          "")
                    locales
                    locales
                    locale)))))

  (define keyboard-layout-config
    (let* ((layout (bootloader-configuration-keyboard-layout config))
           (grub   (bootloader-package
                    (bootloader-configuration-bootloader config)))
           (keymap* (and layout
                         (keyboard-layout-file layout #:grub grub)))
           (entry (first all-entries))
           (device (menu-entry-device entry))
           (mount-point (menu-entry-device-mount-point entry))
           (keymap (and keymap*
                        (normalize-file keymap* mount-point
                                        store-directory-prefix))))
      #~(when #$keymap
          (format port "\
insmod keylayouts
keymap ~a~%" #$keymap))))

  (define builder
    #~(call-with-output-file #$output
        (lambda (port)
          (format port
                  "# This file was generated from your Guix configuration.  Any changes
# will be lost upon reconfiguration.
")
          #$@(crypto-devices)
          #$(sugar)
          #$locale-config
          #$keyboard-layout-config
          (format port "
set default=~a
set timeout=~a~%"
                  #$(bootloader-configuration-default-entry config)
                  #$(bootloader-configuration-timeout config))
          #$@(map menu-entry->gexp all-entries)

          #$@(if (pair? old-entries)
                 #~((format port "
submenu \"GNU system, old configurations...\" {~%")
                    #$@(map menu-entry->gexp old-entries)
                    (format port "}~%"))
                 #~())
          (format port "
if [ \"${grub_platform}\" == efi ]; then
  menuentry \"Firmware setup\" {
    fwsetup
  }
fi~%"))))

  ;; Since this file is rather unique, there's no point in trying to
  ;; substitute it.
  (computed-file "grub.cfg" builder
                 #:options '(#:local-build? #t
                             #:substitutable? #f)))

;;;
;;; Install procedures.
;;;

(define install-grub
  #~(lambda (bootloader device mount-point)
      (let ((grub (string-append bootloader "/sbin/grub-install"))
            (install-dir (string-append mount-point "/boot")))
        ;; Install GRUB on DEVICE which is mounted at MOUNT-POINT. If DEVICE
        ;; is #f, then we populate the disk-image rooted at MOUNT-POINT.
        (if device
            (begin
              ;; Tell 'grub-install' that there might be a LUKS-encrypted
              ;; /boot or root partition.
              (setenv "GRUB_ENABLE_CRYPTODISK" "y")

              ;; Hide potentially confusing messages from the user, such as
              ;; "Installing for i386-pc platform."
              (invoke/quiet grub "--no-floppy" "--target=i386-pc"
                            "--boot-directory" install-dir
                            device))
            ;; When creating a disk-image, only install a font and GRUB modules.
            (let* ((fonts (string-append install-dir "/grub/fonts")))
              (mkdir-p fonts)
              (copy-file (string-append bootloader "/share/grub/unicode.pf2")
                         (string-append fonts "/unicode.pf2"))
              (copy-recursively (string-append bootloader "/lib/")
                                install-dir))))))

(define install-grub-disk-image
  #~(lambda (bootloader root-index image)
      ;; Install GRUB on the given IMAGE. The root partition index is
      ;; ROOT-INDEX.
      (let ((grub-mkimage
             (string-append bootloader "/bin/grub-mkimage"))
            (modules '("biosdisk" "part_msdos" "fat" "ext2"))
            (grub-bios-setup
             (string-append bootloader "/sbin/grub-bios-setup"))
            (root-device (format #f "hd0,msdos~a" root-index))
            (boot-img (string-append bootloader "/lib/grub/i386-pc/boot.img"))
            (device-map "device.map"))

        ;; Create a minimal, standalone GRUB image that will be written
        ;; directly in the MBR-GAP (space between the end of the MBR and the
        ;; first partition).
        (apply invoke grub-mkimage
               "-O" "i386-pc"
               "-o" "core.img"
               "-p" (format #f "(~a)/boot/grub" root-device)
               modules)

        ;; Create a device mapping file.
        (call-with-output-file device-map
          (lambda (port)
            (format port "(hd0) ~a~%" image)))

        ;; Copy the default boot.img, that will be written on the MBR sector
        ;; by GRUB-BIOS-SETUP.
        (copy-file boot-img "boot.img")

        ;; Install both the "boot.img" and the "core.img" files on the given
        ;; IMAGE. On boot, the MBR sector will execute the minimal GRUB
        ;; written in the MBR-GAP. GRUB configuration and missing modules will
        ;; be read from ROOT-DEVICE.
        (invoke grub-bios-setup
                "-m" device-map
                "-r" root-device
                "-d" "."
                image))))

(define install-grub-efi
  #~(lambda (bootloader efi-dir mount-point)
      ;; There is nothing useful to do when called in the context of a disk
      ;; image generation.
      (when efi-dir
        ;; Install GRUB onto the EFI partition mounted at EFI-DIR, for the
        ;; system whose root is mounted at MOUNT-POINT.
        (let ((grub-install (string-append bootloader "/sbin/grub-install"))
              (install-dir (string-append mount-point "/boot"))
              ;; When installing Guix, it's common to mount EFI-DIR below
              ;; MOUNT-POINT rather than /boot/efi on the live image.
              (target-esp (if (file-exists? (string-append mount-point efi-dir))
                              (string-append mount-point efi-dir)
                              efi-dir)))
          ;; Tell 'grub-install' that there might be a LUKS-encrypted /boot or
          ;; root partition.
          (setenv "GRUB_ENABLE_CRYPTODISK" "y")
          (invoke/quiet grub-install "--boot-directory" install-dir
                        "--bootloader-id=Guix"
                        "--efi-directory" target-esp)))))

(define (install-grub-efi-netboot subdir)
  "Define a grub-efi-netboot bootloader installer for installation in SUBDIR,
which is usually efi/Guix or efi/boot."
  (let* ((system (string-split (nix-system->gnu-triplet
                                (or (%current-target-system)
                                    (%current-system)))
                               #\-))
         (arch (first system))
         (boot-efi-link (match system
                          ;; These are the supportend systems and the names
                          ;; defined by the UEFI standard for removable media.
                          (("i686" _ ...)        "/bootia32.efi")
                          (("x86_64" _ ...)      "/bootx64.efi")
                          (("arm" _ ...)         "/bootarm.efi")
                          (("aarch64" _ ...)     "/bootaa64.efi")
                          (("riscv" _ ...)       "/bootriscv32.efi")
                          (("riscv64" _ ...)     "/bootriscv64.efi")
                          ;; Other systems are not supported, although defined.
                          ;; (("riscv128" _ ...) "/bootriscv128.efi")
                          ;; (("ia64" _ ...)     "/bootia64.efi")
                          ((_ ...)               #f)))
         (core-efi (string-append
                    ;; This is the arch dependent file name of GRUB, e.g.
                    ;; i368-efi/core.efi or arm64-efi/core.efi.
                    (match arch
                      ("i686"    "i386")
                      ("aarch64" "arm64")
                      ("riscv"   "riscv32")
                      (_         arch))
                    "-efi/core.efi")))
    (with-imported-modules
     '((guix build union))
     #~(lambda (bootloader target mount-point)
         "Install the BOOTLOADER, which must be the package grub, as e.g.
bootx64.efi or bootaa64.efi into SUBDIR, which is usually efi/Guix or efi/boot,
below the directory TARGET for the system whose root is mounted at MOUNT-POINT.

MOUNT-POINT is the last argument in 'guix system init /etc/config.scm mnt/point'
or '/' for other 'guix system' commands.

TARGET is the target argument given to the bootloader-configuration in

(operating-system
 (bootloader (bootloader-configuration
              (target \"/boot\")
              …))
 …)

TARGET is required to be an absolute directory name, usually mounted via NFS,
and finally needs to be provided by a TFTP server as the TFTP root directory.

GRUB will load tftp://server/SUBDIR/grub.cfg and this file will instruct it to
load more files from the store like tftp://server/gnu/store/…-linux…/Image.

To make this possible two symlinks will be created. The first symlink points
relatively form MOUNT-POINT/TARGET/SUBDIR/grub.cfg to
MOUNT-POINT/boot/grub/grub.cfg, and the second symlink points relatively from
MOUNT-POINT/TARGET/%store-prefix to MOUNT-POINT/%store-prefix.

It is important to note that these symlinks need to be relative, as the absolute
paths on the TFTP server side are unknown.

It is also important to note that both symlinks will point outside the TFTP root
directory and that the TARGET/%store-prefix symlink makes the whole store
accessible via TFTP. Possibly the TFTP server must be configured
to allow accesses outside its TFTP root directory. This may need to be
considered for security aspects."
         (use-modules ((guix build union) #:select (symlink-relative)))
         (let* ((net-dir (string-append mount-point target "/"))
                (sub-dir (string-append net-dir #$subdir "/"))
                (store (string-append mount-point (%store-prefix)))
                (store-link (string-append net-dir (%store-prefix)))
                (grub-cfg (string-append mount-point "/boot/grub/grub.cfg"))
                (grub-cfg-link (string-append sub-dir (basename grub-cfg)))
                (boot-efi-link (string-append sub-dir #$boot-efi-link)))
           ;; Prepare the symlink to the store.
           (mkdir-p (dirname store-link))
           (false-if-exception (delete-file store-link))
           (symlink-relative store store-link)
           ;; Prepare the symlink to the grub.cfg, which points into the store.
           (mkdir-p (dirname grub-cfg-link))
           (false-if-exception (delete-file grub-cfg-link))
           (symlink-relative grub-cfg grub-cfg-link)
           ;; Install GRUB, which refers to the grub.cfg, with support for
           ;; encrypted partitions,
           (setenv "GRUB_ENABLE_CRYPTODISK" "y")
           (invoke/quiet (string-append bootloader "/bin/grub-mknetdir")
                         (string-append "--net-directory=" net-dir)
                         (string-append "--subdir=" #$subdir))
           ;; Prepare the bootloader symlink, which points to core.efi of GRUB.
           (false-if-exception (delete-file boot-efi-link))
           (symlink #$core-efi boot-efi-link))))))

;;;
;;; Bootloader definitions.
;;;
;;; For all these grub-bootloader variables the path to /boot/grub/grub.cfg
;;; is fixed.  Inheriting and overwriting the field 'configuration-file' will
;;; break 'guix system delete-generations', 'guix system switch-generation',
;;; and 'guix system roll-back'.

(define grub-bootloader
  (bootloader
   (name 'grub)
   (package grub)
   (installer install-grub)
   (disk-image-installer install-grub-disk-image)
   (configuration-file "/boot/grub/grub.cfg")
   (configuration-file-generator grub-configuration-file)))

(define grub-minimal-bootloader
  (bootloader
   (inherit grub-bootloader)
   (package grub-minimal)))

(define grub-efi-bootloader
  (bootloader
   (inherit grub-bootloader)
   (installer install-grub-efi)
   (disk-image-installer #f)
   (name 'grub-efi)
   (package grub-efi)))

(define grub-efi-netboot-bootloader
  (bootloader
   (inherit grub-efi-bootloader)
   (name 'grub-efi-netboot-bootloader)
   (installer (install-grub-efi-netboot "efi/Guix"))))

(define grub-mkrescue-bootloader
  (bootloader
   (inherit grub-efi-bootloader)
   (package grub-hybrid)))

;;;
;;; Compatibility macros.
;;;

(define-syntax grub-configuration
  (syntax-rules (grub)
                ((_ (grub package) fields ...)
                 (if (eq? package grub)
                     (bootloader-configuration
                      (bootloader grub-bootloader)
                      fields ...)
                   (bootloader-configuration
                    (bootloader grub-efi-bootloader)
                    fields ...)))
                ((_ fields ...)
                 (bootloader-configuration
                  (bootloader grub-bootloader)
                  fields ...))))

;;; grub.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 David Craven <david@craven.ch>
;;; Copyright © 2017, 2019 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu>
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; 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 u-boot)
  #:use-module (gnu bootloader extlinux)
  #:use-module (gnu bootloader)
  #:use-module (gnu packages bootloaders)
  #:use-module (guix gexp)
  #:export (u-boot-bootloader
            u-boot-a20-olinuxino-lime-bootloader
            u-boot-a20-olinuxino-lime2-bootloader
            u-boot-a20-olinuxino-micro-bootloader
            u-boot-bananapi-m2-ultra-bootloader
            u-boot-beaglebone-black-bootloader
            u-boot-cubietruck-bootloader
            u-boot-firefly-rk3399-bootloader
            u-boot-mx6cuboxi-bootloader
            u-boot-nintendo-nes-classic-edition-bootloader
            u-boot-novena-bootloader
            u-boot-pine64-plus-bootloader
            u-boot-pine64-lts-bootloader
            u-boot-pinebook-bootloader
            u-boot-pinebook-pro-rk3399-bootloader
            u-boot-puma-rk3399-bootloader
            u-boot-rock64-rk3328-bootloader
            u-boot-rockpro64-rk3399-bootloader
            u-boot-wandboard-bootloader))

(define install-u-boot
  #~(lambda (bootloader root-index image)
      (if bootloader
        (error "Failed to install U-Boot"))))

(define install-beaglebone-black-u-boot
  ;; http://wiki.beyondlogic.org/index.php?title=BeagleBoneBlack_Upgrading_uBoot
  ;; This first stage bootloader called MLO (U-Boot SPL) is expected at
  ;; 0x20000 by BBB ROM code. The second stage bootloader will be loaded by
  ;; the MLO and is expected at 0x60000.  Write both first stage ("MLO") and
  ;; second stage ("u-boot.img") images, read in BOOTLOADER directory, to the
  ;; specified DEVICE.
  #~(lambda (bootloader root-index image)
      (let ((mlo (string-append bootloader "/libexec/MLO"))
            (u-boot (string-append bootloader "/libexec/u-boot.img")))
        (write-file-on-device mlo (* 256 512)
                              image (* 256 512))
        (write-file-on-device u-boot (* 1024 512)
                              image (* 768 512)))))

(define install-allwinner-u-boot
  #~(lambda (bootloader root-index image)
      (let ((u-boot (string-append bootloader
                                   "/libexec/u-boot-sunxi-with-spl.bin")))
        (write-file-on-device u-boot (stat:size (stat u-boot))
                              image (* 8 1024)))))

(define install-allwinner64-u-boot
  #~(lambda (bootloader root-index image)
      (let ((spl (string-append bootloader "/libexec/u-boot-sunxi-with-spl.bin"))
            (u-boot (string-append bootloader "/libexec/u-boot-sunxi-with-spl.fit.itb")))
        (write-file-on-device spl (stat:size (stat spl))
                              image (* 8 1024))
        (write-file-on-device u-boot (stat:size (stat u-boot))
                              image (* 40 1024)))))

(define install-imx-u-boot
  #~(lambda (bootloader root-index image)
      (let ((spl (string-append bootloader "/libexec/SPL"))
            (u-boot (string-append bootloader "/libexec/u-boot.img")))
        (write-file-on-device spl (stat:size (stat spl))
                              image (* 1 1024))
        (write-file-on-device u-boot (stat:size (stat u-boot))
                              image (* 69 1024)))))

(define install-puma-rk3399-u-boot
  #~(lambda (bootloader root-index image)
      (let ((spl (string-append bootloader "/libexec/idbloader.img"))
            (u-boot (string-append bootloader "/libexec/u-boot.itb")))
        (write-file-on-device spl (stat:size (stat spl))
                              image (* 64 512))
        (write-file-on-device u-boot (stat:size (stat u-boot))
                              image (* 512 512)))))

(define install-firefly-rk3399-u-boot
  #~(lambda (bootloader root-index image)
      (let ((idb (string-append bootloader "/libexec/idbloader.img"))
            (u-boot (string-append bootloader "/libexec/u-boot.itb")))
        (write-file-on-device idb (stat:size (stat idb))
                              image (* 64 512))
        (write-file-on-device u-boot (stat:size (stat u-boot))
                              image (* 16384 512)))))

(define install-rock64-rk3328-u-boot
  #~(lambda (bootloader root-index image)
      (let ((idb (string-append bootloader "/libexec/idbloader.img"))
            (u-boot (string-append bootloader "/libexec/u-boot.itb")))
        (write-file-on-device idb (stat:size (stat idb))
                              image (* 64 512))
        (write-file-on-device u-boot (stat:size (stat u-boot))
                              image (* 16384 512)))))

(define install-rockpro64-rk3399-u-boot
  #~(lambda (bootloader root-index image)
      (let ((idb (string-append bootloader "/libexec/idbloader.img"))
            (u-boot (string-append bootloader "/libexec/u-boot.itb")))
        (write-file-on-device idb (stat:size (stat idb))
                              image (* 64 512))
        (write-file-on-device u-boot (stat:size (stat u-boot))
                              image (* 16384 512)))))

(define install-pinebook-pro-rk3399-u-boot install-rockpro64-rk3399-u-boot)

;;;
;;; Bootloader definitions.
;;;

(define u-boot-bootloader
  (bootloader
   (inherit extlinux-bootloader)
   (name 'u-boot)
   (package #f)
   (installer #f)
   (disk-image-installer install-u-boot)))

(define u-boot-beaglebone-black-bootloader
  (bootloader
   (inherit u-boot-bootloader)
   (package u-boot-am335x-boneblack)
   (disk-image-installer install-beaglebone-black-u-boot)))

(define u-boot-allwinner-bootloader
  (bootloader
   (inherit u-boot-bootloader)
   (disk-image-installer install-allwinner-u-boot)))

(define u-boot-allwinner64-bootloader
  (bootloader
   (inherit u-boot-bootloader)
   (disk-image-installer install-allwinner64-u-boot)))

(define u-boot-imx-bootloader
  (bootloader
   (inherit u-boot-bootloader)
   (disk-image-installer install-imx-u-boot)))

(define u-boot-nintendo-nes-classic-edition-bootloader
  (bootloader
    (inherit u-boot-allwinner-bootloader)
    (package u-boot-nintendo-nes-classic-edition)))

(define u-boot-a20-olinuxino-lime-bootloader
  (bootloader
   (inherit u-boot-allwinner-bootloader)
   (package u-boot-a20-olinuxino-lime)))

(define u-boot-a20-olinuxino-lime2-bootloader
  (bootloader
   (inherit u-boot-allwinner-bootloader)
   (package u-boot-a20-olinuxino-lime2)))

(define u-boot-a20-olinuxino-micro-bootloader
  (bootloader
   (inherit u-boot-allwinner-bootloader)
   (package u-boot-a20-olinuxino-micro)))

(define u-boot-bananapi-m2-ultra-bootloader
  (bootloader
   (inherit u-boot-allwinner-bootloader)
   (package u-boot-bananapi-m2-ultra)))

(define u-boot-cubietruck-bootloader
  (bootloader
    (inherit u-boot-allwinner-bootloader)
    (package u-boot-cubietruck)))

(define u-boot-firefly-rk3399-bootloader
  ;; SD and eMMC use the same format
  (bootloader
   (inherit u-boot-bootloader)
   (package u-boot-firefly-rk3399)
   (disk-image-installer install-firefly-rk3399-u-boot)))

(define u-boot-mx6cuboxi-bootloader
  (bootloader
   (inherit u-boot-imx-bootloader)
   (package u-boot-mx6cuboxi)))

(define u-boot-wandboard-bootloader
  (bootloader
   (inherit u-boot-imx-bootloader)
   (package u-boot-wandboard)))

(define u-boot-novena-bootloader
  (bootloader
   (inherit u-boot-imx-bootloader)
   (package u-boot-novena)))

(define u-boot-pine64-plus-bootloader
  (bootloader
   (inherit u-boot-allwinner64-bootloader)
   (package u-boot-pine64-plus)))

(define u-boot-pine64-lts-bootloader
  (bootloader
   (inherit u-boot-allwinner-bootloader)
   (package u-boot-pine64-lts)))

(define u-boot-pinebook-bootloader
  (bootloader
   (inherit u-boot-allwinner64-bootloader)
   (package u-boot-pinebook)))

(define u-boot-puma-rk3399-bootloader
  (bootloader
   (inherit u-boot-bootloader)
   (package u-boot-puma-rk3399)
   (disk-image-installer install-puma-rk3399-u-boot)))

(define u-boot-rock64-rk3328-bootloader
  ;; SD and eMMC use the same format
  (bootloader
   (inherit u-boot-bootloader)
   (package u-boot-rock64-rk3328)
   (disk-image-installer install-rock64-rk3328-u-boot)))

(define u-boot-rockpro64-rk3399-bootloader
  ;; SD and eMMC use the same format
  (bootloader
   (inherit u-boot-bootloader)
   (package u-boot-rockpro64-rk3399)
   (disk-image-installer install-rockpro64-rk3399-u-boot)))

(define u-boot-pinebook-pro-rk3399-bootloader
  ;; SD and eMMC use the same format
  (bootloader
   (inherit u-boot-bootloader)
   (package u-boot-pinebook-pro-rk3399)
   (disk-image-installer install-pinebook-pro-rk3399-u-boot)))