system: grub: Add preliminary support for themes.

* gnu/system/grub.scm (<grub-image>, <grub-theme>): New record types.
  (%artwork-repository, %background-image): New variables.
  (<grub-configuration>)[theme]: New field.
  (svg->png, resize-image, grub-background-image, eye-candy): New
  procedures.
  (grub-configuration-file): Use 'eye-candy' and add it in BUILDER.

1 files changed, 165 insertions, 20 deletions

diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm
index 41f45f1558..67375b45cf 100644
--- a/gnu/system/grub.scm
+++ b/gnu/system/grub.scm
@@ -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