From 20e3dd052d7e4f59273e3646d3533d43c87c30b0 Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Date: Sat, 2 Oct 2021 21:28:24 -0400
Subject: profiles: Add a gdk-pixbuf-loaders-cache-file hook.

This paves the way toward properly fixing https://issues.guix.gnu.org/50957.

* guix/profiles.scm (gdk-pixbuf-loaders-cache-file): Add procedure...
(%default-profile-hooks): ... and register it as a profile hook.
* guix/status.scm (hook-message): Register it here too.
---
 guix/profiles.scm | 47 ++++++++++++++++++++++++++++++++++++++++++++++-
 guix/status.scm   |  2 ++
 2 files changed, 48 insertions(+), 1 deletion(-)

(limited to 'guix')

diff --git a/guix/profiles.scm b/guix/profiles.scm
index dcd0d30de1..885d7c8d40 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -7,7 +7,7 @@
 ;;; Copyright © 2016, 2018, 2019, 2021 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
 ;;; Copyright © 2017 Huang Ying <huang.ying.caritas@gmail.com>
-;;; Copyright © 2017 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2017, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;; Copyright © 2019 Kyle Meyer <kyle@kyleam.com>
 ;;; Copyright © 2019 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2020 Danny Milosavljevic <dannym@scratchpost.org>
@@ -1180,6 +1180,50 @@ MANIFEST.  Single-file bundles are required by programs such as Git and Lynx."
                     `((type . profile-hook)
                       (hook . emacs-subdirs))))
 
+(define (gdk-pixbuf-loaders-cache-file manifest)
+  "Return a derivation that produces a loaders cache file for every gdk-pixbuf
+loaders discovered in MANIFEST."
+  (define gdk-pixbuf                    ;lazy reference
+    (module-ref (resolve-interface '(gnu packages gtk)) 'gdk-pixbuf))
+
+  (mlet* %store-monad
+      ((gdk-pixbuf (manifest-lookup-package manifest "gdk-pixbuf"))
+       (librsvg (manifest-lookup-package manifest "librsvg"))
+       (gdk-pixbuf-bin -> (file-append gdk-pixbuf "/bin")))
+
+    (define build
+      (with-imported-modules (source-module-closure
+                              '((guix build glib-or-gtk-build-system)))
+        #~(begin
+            (use-modules (guix build glib-or-gtk-build-system))
+            (setenv "PATH" (string-append #$gdk-pixbuf-bin ":" (getenv "PATH")))
+
+            (generate-gdk-pixbuf-loaders-cache
+             ;; XXX: MANIFEST-LOOKUP-PACKAGE transitively searches through
+             ;; every input referenced by the manifest, while MANIFEST-INPUTS
+             ;; only retrieves the immediate inputs as well as their
+             ;; propagated inputs; to avoid causing an empty output derivation
+             ;; we must ensure that the inputs contain at least one
+             ;; loaders.cache file.  This is why we include gdk-pixbuf or
+             ;; librsvg when they are transitively found.
+             (list #$@(if gdk-pixbuf
+                          (list gdk-pixbuf)
+                          '())
+                   #$@(if librsvg
+                          (list librsvg)
+                          '())
+                   #$@(manifest-inputs manifest))
+             (list #$output)))))
+
+    (if gdk-pixbuf
+        (gexp->derivation "gdk-pixbuf-loaders-cache-file" build
+                          #:local-build? #t
+                          #:substitutable? #f
+                          #:properties
+                          '((type . profile-hook)
+                            (hook . gdk-pixbuf-loaders-cache-file)))
+        (return #f))))
+
 (define (glib-schemas manifest)
   "Return a derivation that unions all schemas from manifest entries and
 creates the Glib 'gschemas.compiled' file."
@@ -1799,6 +1843,7 @@ MANIFEST."
         ghc-package-cache-file
         ca-certificate-bundle
         emacs-subdirs
+        gdk-pixbuf-loaders-cache-file
         glib-schemas
         gtk-icon-themes
         gtk-im-modules
diff --git a/guix/status.scm b/guix/status.scm
index f351a56d92..eefe18365f 100644
--- a/guix/status.scm
+++ b/guix/status.scm
@@ -381,6 +381,8 @@ the current build phase."
      (G_ "building CA certificate bundle..."))
     ('emacs-subdirs
      (G_ "listing Emacs sub-directories..."))
+    ('gdk-pixbuf-loaders-cache-file
+     (G_ "generating GdkPixbuf loaders cache..."))
     ('glib-schemas
      (G_ "generating GLib schema cache..."))
     ('gtk-icon-themes
-- 
cgit v1.2.3