[PATCH] system: grub: Use librsvg to convert SVG to PNG

[Mark H Weaver]

Hello Guix,

The attached patch eliminates the use of 'inkscape' and 'imagemagick' to
convert our grub background image from SVG to PNG.  The job is now done
using 'librsvg' [1] via Guile's dynamic FFI.  I was unable to perform
the needed scaling using the 'rsvg-convert' program, so I had to use
librsvg directly.

As a side benefit, the resulting image quality should be superior when
scaling is performed, because scaling is now effectively done in the
vector representation during rendering, whereas previously it was done
in the raster representation as a separate step.

What do you think?

      Mark


[1] Note that in the past, 'librsvg' was unable to properly convert our
    SVG file, but that problem seems to be fixed.

>From a50f358b083cff4d156cd7116fee516952fc9bcf Mon Sep 17 00:00:00 2001
From: Mark H Weaver <address@hidden>
Date: Fri, 2 Sep 2016 02:26:43 -0400
Subject: [PATCH] system: grub: Use librsvg to convert SVG to PNG.

* guix/build/svg.scm: New file.
* Makefile.am (MODULES): Add it.
* gnu/system/grub.scm (svg->png): Add 'width' and 'height' arguments.
Reimplement using (guix build svg).  Drop references to 'inkscape' and
'imagemagick'.
(resize-image): Remove.
(grub-background-image): Adapt to the incorporation of scaling into
'svg->png'.
---
 Makefile.am         |   1 +
 gnu/system/grub.scm |  34 +++++++----------
 guix/build/svg.scm  | 108 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 122 insertions(+), 21 deletions(-)
 create mode 100644 guix/build/svg.scm

diff --git a/Makefile.am b/Makefile.am
index 79abd6b..f5ceeb6 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -101,6 +101,7 @@ MODULES =                                   \
   guix/build/pull.scm                          \
   guix/build/rpath.scm                         \
   guix/build/cvs.scm                           \
+  guix/build/svg.scm                           \
   guix/build/svn.scm                           \
   guix/build/syscalls.scm                       \
   guix/build/gremlin.scm                       \
diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm
index 45b46ca..e61dbcf 100644
--- a/gnu/system/grub.scm
+++ b/gnu/system/grub.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <address@hidden>
+;;; Copyright © 2016 Mark H Weaver <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -27,8 +28,7 @@
   #:use-module (gnu artwork)
   #:use-module (gnu system file-systems)
   #:autoload   (gnu packages grub) (grub)
-  #:autoload   (gnu packages inkscape) (inkscape)
-  #:autoload   (gnu packages imagemagick) (imagemagick)
+  #:autoload   (gnu packages gnome) (librsvg)
   #:autoload   (gnu packages compression) (gzip)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
@@ -121,25 +121,18 @@
 ;;; Background image & themes.
 ;;;
 
-(define (svg->png svg)
-  "Build a PNG from SVG."
+(define* (svg->png svg #:optional width height)
+  "Build a PNG of size WIDTH and HEIGHT from SVG.  If omitted, WIDTH and
+HEIGHT default to the natural image size."
   ;; 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)))))
+                    #~(begin
+                        (use-modules (guix build svg))
+                        (svg->png #$svg #$output
+                                  #:width #$width
+                                  #:height #$height
+                                  #:librsvg #$librsvg))
+                    #:modules '((guix build svg))))
 
 (define* (grub-background-image config #:key (width 1024) (height 768))
   "Return the GRUB background image defined in CONFIG with a ratio of
@@ -149,8 +142,7 @@ WIDTH/HEIGHT, or #f if none was found."
                         (= (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))
+        (svg->png (grub-image-file image) width height)
         (with-monad %store-monad
           (return #f)))))
 
diff --git a/guix/build/svg.scm b/guix/build/svg.scm
new file mode 100644
index 0000000..610734b
--- /dev/null
+++ b/guix/build/svg.scm
@@ -0,0 +1,108 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 Mark H Weaver <address@hidden>
+;;;
+;;; 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 (guix build svg)
+  #:use-module (ice-9 match)
+  #:use-module (system foreign)
+  #:use-module (rnrs bytevectors)
+  #:export (svg->png))
+
+(define (null-check! message)
+  (match-lambda
+    ((? null-pointer?)
+     (error message))
+    (pointer pointer)))
+
+(define (int-bool-check! message)
+  (match-lambda
+    (0 (error message))
+    (_ #t)))
+
+(define CAIRO_STATUS_SUCCESS 0)
+(define (cairo-status-check! message)
+  (lambda (status)
+    (or (= status CAIRO_STATUS_SUCCESS)
+        (error message status))))
+
+(define* (svg->png svg png #:key width height librsvg)
+  "Build a PNG of size WIDTH and HEIGHT from SVG using LIBRSVG.
+If omitted, WIDTH and HEIGHT default to the natural image size."
+
+  (define library
+    (dynamic-link (if librsvg
+                      (string-append librsvg "/lib/librsvg-2.so")
+                      "librsvg-2.so")))
+
+  (define (c-function return-type name arg-types)
+    (pointer->procedure return-type (dynamic-func name library) arg-types))
+
+  (define rsvg-handle-new-from-file
+    (compose (null-check! "rsvg-handle-new-from-file failed")
+             (c-function '* "rsvg_handle_new_from_file" '(* *))
+             (lambda (name)
+               (values (string->pointer name)
+                       (make-c-struct '(*) (list %null-pointer))))))
+
+  (define rsvg-handle-get-dimensions
+    (let ((get-dimensions*
+           (c-function void "rsvg_handle_get_dimensions" '(* *)))
+          (type (list int int double double)))
+      (lambda (handle)
+        (let ((dimensions (make-c-struct type '(0 0 0 0))))
+          (get-dimensions* handle dimensions)
+          (parse-c-struct dimensions type)))))
+
+  (define rsvg-handle-render-cairo
+    (compose (int-bool-check! "rsvg-handle-render-cairo failed")
+             (c-function int "rsvg_handle_render_cairo" '(* *))))
+
+  (define g-object-unref
+    (c-function void "g_object_unref" '(*)))
+
+  (define CAIRO_FORMAT_ARGB32 0)
+  (define cairo-image-surface-create
+    (compose (null-check! "cairo-image-surface-create failed")
+             (c-function '* "cairo_image_surface_create"
+                         (list int int int))))
+  (define cairo-create (compose (null-check! "cairo-create failed")
+                                (c-function '* "cairo_create" '(*))))
+  (define cairo-scale (c-function void "cairo_scale" (list '* double double)))
+  (define cairo-destroy (c-function void "cairo_destroy" '(*)))
+  (define cairo-surface-destroy (c-function void "cairo_surface_destroy" '(*)))
+
+  (define cairo-surface-write-to-png
+    (compose (cairo-status-check! "cairo-surface-write-to-png failed")
+             (c-function int "cairo_surface_write_to_png" '(* *))
+             (lambda (surface name)
+               (values surface (string->pointer name)))))
+
+  (let ((rsvg-handle (rsvg-handle-new-from-file svg)))
+    (match (rsvg-handle-get-dimensions rsvg-handle)
+      ((natural-width natural-height . _)
+       (let* ((width    (or width  natural-width))
+              (height   (or height natural-height))
+              (surface  (cairo-image-surface-create CAIRO_FORMAT_ARGB32
+                                                    width height))
+              (cr       (cairo-create surface)))
+         (cairo-scale cr (/ width natural-width) (/ height natural-height))
+         (rsvg-handle-render-cairo rsvg-handle cr)
+         (g-object-unref rsvg-handle)
+         (cairo-surface-write-to-png surface png)
+         (cairo-destroy cr)
+         (cairo-surface-destroy surface)
+         #t)))))
-- 
2.9.3