1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
4 ;;; This file is part of GNU Guix.
6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
7 ;;; under the terms of the GNU General Public License as published by
8 ;;; the Free Software Foundation; either version 3 of the License, or (at
9 ;;; your option) any later version.
11 ;;; GNU Guix is distributed in the hope that it will be useful, but
12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ;;; GNU General Public License for more details.
16 ;;; You should have received a copy of the GNU General Public License
17 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
19 (define-module (gnu system grub)
20 #:use-module (guix store)
21 #:use-module (guix packages)
22 #:use-module (guix derivations)
23 #:use-module (guix records)
24 #:use-module (guix monads)
25 #:use-module (guix gexp)
26 #:use-module (guix download)
27 #:use-module (gnu artwork)
28 #:use-module (gnu system file-systems)
29 #:autoload (gnu packages grub) (grub)
30 #:autoload (gnu packages compression) (gzip)
31 #:autoload (gnu packages gtk) (guile-cairo guile-rsvg)
32 #:use-module (ice-9 match)
33 #:use-module (ice-9 regex)
34 #:use-module (srfi srfi-1)
37 grub-image-aspect-ratio
43 grub-theme-color-normal
44 grub-theme-color-highlight
51 grub-configuration-device
56 grub-configuration-file))
60 ;;; Configuration of GNU GRUB.
64 (define (strip-mount-point fs file)
65 "Strip the mount point of FS from FILE, which is a gexp or other lowerable
66 object denoting a file name."
67 (let ((mount-point (file-system-mount-point fs)))
68 (if (string=? mount-point "/")
70 #~(let ((file #$file))
71 (if (string-prefix? #$mount-point file)
72 (substring #$file #$(string-length mount-point))
75 (define-record-type* <grub-image>
76 grub-image make-grub-image
78 (aspect-ratio grub-image-aspect-ratio ;rational number
80 (file grub-image-file)) ;file-valued gexp (SVG)
82 (define-record-type* <grub-theme>
83 grub-theme make-grub-theme
85 (images grub-theme-images
86 (default '())) ;list of <grub-image>
87 (color-normal grub-theme-color-normal
88 (default '((fg . cyan) (bg . blue))))
89 (color-highlight grub-theme-color-highlight
90 (default '((fg . white) (bg . blue)))))
92 (define %background-image
95 (file #~(string-append #$%artwork-repository
96 "/grub/GuixSD-fully-black-4-3.svg"))))
98 (define %default-theme
99 ;; Default theme contributed by Felipe López.
101 (images (list %background-image))
102 (color-highlight '((fg . yellow) (bg . black)))
103 (color-normal '((fg . light-gray) (bg . black))))) ;XXX: #x303030
105 (define-record-type* <grub-configuration>
106 grub-configuration make-grub-configuration
108 (grub grub-configuration-grub ; package
109 (default (@ (gnu packages grub) grub)))
110 (device grub-configuration-device) ; string
111 (menu-entries grub-configuration-menu-entries ; list
113 (default-entry grub-configuration-default-entry ; integer
115 (timeout grub-configuration-timeout ; integer
117 (theme grub-configuration-theme ; <grub-theme>
118 (default %default-theme)))
120 (define-record-type* <menu-entry>
121 menu-entry make-menu-entry
123 (label menu-entry-label)
124 (linux menu-entry-linux)
125 (linux-arguments menu-entry-linux-arguments
126 (default '())) ; list of string-valued gexps
127 (initrd menu-entry-initrd)) ; file name of the initrd as a gexp
131 ;;; Background image & themes.
134 (define* (svg->png svg #:key width height)
135 "Build a PNG of HEIGHT x WIDTH from SVG."
136 (gexp->derivation "grub-image.png"
137 (with-imported-modules '((gnu build svg))
139 ;; We need these two libraries.
140 (add-to-load-path (string-append #$guile-rsvg
142 (effective-version)))
143 (add-to-load-path (string-append #$guile-cairo
145 (effective-version)))
147 (use-modules (gnu build svg))
148 (svg->png #$svg #$output
150 #:height #$height)))))
152 (define* (grub-background-image config #:key (width 1024) (height 768))
153 "Return the GRUB background image defined in CONFIG with a ratio of
154 WIDTH/HEIGHT, or #f if none was found."
155 (let* ((ratio (/ width height))
156 (image (find (lambda (image)
157 (= (grub-image-aspect-ratio image) ratio))
158 (grub-theme-images (grub-configuration-theme config)))))
160 (svg->png (grub-image-file image)
161 #:width width #:height height)
162 (with-monad %store-monad
165 (define (eye-candy config root-fs system port)
166 "Return in %STORE-MONAD a gexp that writes to PORT (a port-valued gexp) the
167 'grub.cfg' part concerned with graphics mode, background images, colors, and
168 all that. ROOT-FS is a file-system object denoting the root file system where
169 the store is. SYSTEM must be the target system string---e.g.,
171 (define setup-gfxterm-body
172 ;; Intel systems need to be switched into graphics mode, whereas most
173 ;; other modern architectures have no other mode and therefore don't need
175 (if (string-match "^(x86_64|i[3-6]86)-" system)
177 # Leave 'gfxmode' to 'auto'.
183 terminal_output gfxterm
187 (define (theme-colors type)
188 (let* ((theme (grub-configuration-theme config))
189 (colors (type theme)))
190 (string-append (symbol->string (assoc-ref colors 'fg)) "/"
191 (symbol->string (assoc-ref colors 'bg)))))
194 (strip-mount-point root-fs
195 (file-append grub "/share/grub/unicode.pf2")))
197 (mlet* %store-monad ((image (grub-background-image config)))
200 function setup_gfxterm {~a}
202 # Set 'root' to the partition that contains /gnu/store.
210 if background_image ~a; then
212 set color_highlight=~a
214 set menu_color_normal=cyan/blue
215 set menu_color_highlight=white/blue
218 #$(grub-root-search root-fs font-file)
221 #$(strip-mount-point root-fs image)
222 #$(theme-colors grub-theme-color-normal)
223 #$(theme-colors grub-theme-color-highlight))))))
227 ;;; Configuration file.
230 (define (grub-root-search root-fs file)
231 "Return the GRUB 'search' command to look for ROOT-FS, which contains FILE,
232 a gexp. The result is a gexp that can be inserted in the grub.cfg-generation
234 ;; Usually FILE is a file name gexp like "/gnu/store/…-linux/vmlinuz", but
235 ;; it can also be something like "(hd0,msdos1)/vmlinuz" in the case of
236 ;; custom menu entries. In the latter case, don't emit a 'search' command.
237 (if (and (string? file) (not (string-prefix? "/" file)))
239 (case (file-system-title root-fs)
240 ;; Preferably refer to ROOT-FS by its UUID or label. This is more
241 ;; efficient and less ambiguous, see <>.
243 (format #f "search --fs-uuid --set ~a"
244 (uuid->string (file-system-device root-fs))))
246 (format #f "search --label --set ~a"
247 (file-system-device root-fs)))
249 ;; As a last resort, look for any device containing FILE.
250 #~(format #f "search --file --set ~a" #$file)))))
252 (define* (grub-configuration-file config store-fs entries
254 (system (%current-system))
256 "Return the GRUB configuration file corresponding to CONFIG, a
257 <grub-configuration> object, and where the store is available at STORE-FS, a
258 <file-system> object. OLD-ENTRIES is taken to be a list of menu entries
259 corresponding to old generations of the system."
261 (append entries (grub-configuration-menu-entries config)))
265 (($ <menu-entry> label linux arguments initrd)
266 ;; Use the right file names for LINUX and STORE-FS in case STORE-FS is
267 ;; not the "/" file system.
268 (let ((linux (strip-mount-point store-fs linux))
269 (initrd (strip-mount-point store-fs initrd)))
270 #~(format port "menuentry ~s {
276 #$(grub-root-search store-fs linux)
277 #$linux (string-join (list #$@arguments))
280 (mlet %store-monad ((sugar (eye-candy config store-fs system #~port)))
282 #~(call-with-output-file #$output
285 "# This file was generated from your GuixSD configuration. Any changes
286 # will be lost upon reconfiguration.
292 #$(grub-configuration-default-entry config)
293 #$(grub-configuration-timeout config))
294 #$@(map entry->gexp all-entries)
296 #$@(if (pair? old-entries)
298 submenu \"GNU system, old configurations...\" {~%")
299 #$@(map entry->gexp old-entries)
303 (gexp->derivation "grub.cfg" builder)))
305 ;;; grub.scm ends here