@@ 23,9 23,29 @@
#:use-module (guix records)
#:use-module (guix monads)
#:use-module (guix gexp)
+ #:use-module (guix download)
+ #:use-module (guix git-download)
+ #:autoload (gnu packages grub) (grub)
+ #:autoload (gnu packages inkscape) (inkscape)
+ #:autoload (gnu packages imagemagick) (imagemagick)
+ #:autoload (gnu packages compression) (gzip)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
- #:export (grub-configuration
+ #:export (grub-image
+ grub-image?
+ grub-image-aspect-ratio
+ grub-image-file
+
+ grub-theme
+ grub-theme?
+ grub-theme-images
+ grub-theme-color-normal
+ grub-theme-color-highlight
+
+ %background-image
+ %default-theme
+
+ grub-configuration
grub-configuration?
grub-configuration-device
@@ 40,6 60,45 @@
;;;
;;; Code:
+(define-record-type* <grub-image>
+ grub-image make-grub-image
+ grub-image?
+ (aspect-ratio grub-image-aspect-ratio ;rational number
+ (default 4/3))
+ (file grub-image-file)) ;file-valued gexp (SVG)
+
+(define-record-type* <grub-theme>
+ grub-theme make-grub-theme
+ grub-theme?
+ (images grub-theme-images
+ (default '())) ;list of <grub-image>
+ (color-normal grub-theme-color-normal
+ (default '((fg . cyan) (bg . blue))))
+ (color-highlight grub-theme-color-highlight
+ (default '((fg . white) (bg . blue)))))
+
+(define %artwork-repository
+ (origin
+ (method git-fetch)
+ (uri (git-reference
+ (url "git://git.savannah.gnu.org/guix/guix-artwork.git")
+ (commit "281157a")))
+ (sha256
+ (base32
+ "02x1myh013mzqnr28d4k1mxs4malv5vszpxdwkjarbhbbkchypz5"))))
+
+(define %background-image
+ (grub-image
+ (aspect-ratio 4/3)
+ (file #~(string-append #$%artwork-repository "/grub/guix-4-3.svg"))))
+
+(define %default-theme
+ ;; Default theme contributed by Felipe López.
+ (grub-theme
+ (images (list %background-image))
+ (color-highlight '((fg . white) (bg . black))) ;XXX: fg should be #x3bb7f5
+ (color-normal '((fg . light-gray) (bg . black))))) ;XXX: #x303030
+
(define-record-type* <grub-configuration>
grub-configuration make-grub-configuration
grub-configuration?
@@ 51,7 110,9 @@
(default-entry grub-configuration-default-entry ; integer
(default 0))
(timeout grub-configuration-timeout ; integer
- (default 5)))
+ (default 5))
+ (theme grub-configuration-theme ; <grub-theme>
+ (default %default-theme)))
(define-record-type* <menu-entry>
menu-entry make-menu-entry
@@ 62,6 123,88 @@
(default '())) ; list of string-valued gexps
(initrd menu-entry-initrd)) ; file name of the initrd as a gexp
+
+;;;
+;;; Background image & themes.
+;;;
+
+(define (svg->png svg)
+ "Build a PNG from SVG."
+ ;; Don't use #:local-build? so that it's substitutable.
+ (gexp->derivation "grub-image.png"
+ #~(zero?
+ (system* (string-append #$inkscape "/bin/inkscape")
+ "--without-gui"
+ (string-append "--export-png=" #$output)
+ #$svg))))
+
+(define (resize-image image width height)
+ "Resize IMAGE to WIDTHxHEIGHT."
+ ;; Don't use #:local-build? so that it's substitutable.
+ (let ((size (string-append (number->string width)
+ "x" (number->string height))))
+ (gexp->derivation "grub-image.resized.png"
+ #~(zero?
+ (system* (string-append #$imagemagick "/bin/convert")
+ "-resize" #$size #$image #$output)))))
+
+(define* (grub-background-image config #:key (width 640) (height 480))
+ "Return the GRUB background image defined in CONFIG with a ratio of
+WIDTH/HEIGHT, or #f if none was found."
+ (let* ((ratio (/ width height))
+ (image (find (lambda (image)
+ (= (grub-image-aspect-ratio image) ratio))
+ (grub-theme-images (grub-configuration-theme config)))))
+ (if image
+ (mlet %store-monad ((png (svg->png (grub-image-file image))))
+ (resize-image png width height))
+ (with-monad %store-monad
+ (return #f)))))
+
+(define (eye-candy config port)
+ "Return in %STORE-MONAD a gexp that writes to PORT (a port-valued gexp) the
+'grub.cfg' part concerned with graphics mode, background images, colors, and
+all that."
+ (define (theme-colors type)
+ (let* ((theme (grub-configuration-theme config))
+ (colors (type theme)))
+ (string-append (symbol->string (assoc-ref colors 'fg)) "/"
+ (symbol->string (assoc-ref colors 'bg)))))
+
+ (mlet* %store-monad ((image (grub-background-image config)))
+ (return (and image #~(format #$port "
+function load_video {
+ insmod vbe
+ insmod vga
+ insmod video_bochs
+ insmod video_cirrus
+}
+
+if loadfont ~a/share/grub/unicode.pf2; then
+ set gfxmode=640x480
+ load_video
+ insmod gfxterm
+ terminal_output gfxterm
+fi
+
+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
+ #$image
+ #$(theme-colors grub-theme-color-normal)
+ #$(theme-colors grub-theme-color-highlight))))))
+
+
+;;;
+;;; Configuration file.
+;;;
+
(define* (grub-configuration-file config entries
#:key
(system (%current-system))
@@ 83,28 226,30 @@ entries corresponding to old generations of the system."
#$linux (string-join (list #$@arguments))
#$initrd))))
- (define builder
- #~(call-with-output-file #$output
- (lambda (port)
- (format port "
+ (mlet %store-monad ((sugar (eye-candy config #~port)))
+ (define builder
+ #~(call-with-output-file #$output
+ (lambda (port)
+ #$sugar
+ (format port "
set default=~a
set timeout=~a
search.file ~a/bzImage~%"
- #$(grub-configuration-default-entry config)
- #$(grub-configuration-timeout config)
- #$(any (match-lambda
- (($ <menu-entry> _ linux)
- linux))
- all-entries))
- #$@(map entry->gexp all-entries)
-
- #$@(if (pair? old-entries)
- #~((format port "
+ #$(grub-configuration-default-entry config)
+ #$(grub-configuration-timeout config)
+ #$(any (match-lambda
+ (($ <menu-entry> _ linux)
+ linux))
+ all-entries))
+ #$@(map entry->gexp all-entries)
+
+ #$@(if (pair? old-entries)
+ #~((format port "
submenu \"GNU system, old configurations...\" {~%")
- #$@(map entry->gexp old-entries)
- (format port "}~%"))
- #~()))))
+ #$@(map entry->gexp old-entries)
+ (format port "}~%"))
+ #~()))))
- (gexp->derivation "grub.cfg" builder))
+ (gexp->derivation "grub.cfg" builder)))
;;; grub.scm ends here