[bug#29930] [PATCH 4/5] profiles: Filter out unwanted manifest entries for profile hooks.

[宋文武]

* guix/profiles.scm (manual-database, fonts-dir-file, ghc-package-cache-file)
(ca-certificate-bundle, gtk-icon-themes, gtk-im-modules)
(xdg-desktop-database, xdg-mime-database): Use 'eval-gexp' to filter out
unwanted manifest inputs.
---
 guix/profiles.scm | 164 ++++++++++++++++++++++++++++++++++++------------------
 1 file changed, 111 insertions(+), 53 deletions(-)

diff --git a/guix/profiles.scm b/guix/profiles.scm
index f6e455c96..7d69d1a53 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -733,7 +733,15 @@ entries of MANIFEST, or #f if MANIFEST does not have any 
GHC packages."
   (define ghc                                     ;lazy reference
     (module-ref (resolve-interface '(gnu packages haskell)) 'ghc))
 
-  (define build
+  (define interested
+    (eval-gexp
+     #~(filter
+        (lambda (input)
+          (file-exists? (string-append input "/lib/ghc-"
+                                       #$(package-version ghc))))
+        '#$(manifest-inputs manifest))))
+
+  (define (build inputs)
     (with-imported-modules '((guix build utils))
       #~(begin
           (use-modules (guix build utils)
@@ -763,9 +771,7 @@ entries of MANIFEST, or #f if MANIFEST does not have any 
GHC packages."
 
           (system* (string-append #+ghc "/bin/ghc-pkg") "init" db-dir)
           (for-each copy-conf-file
-                    (append-map conf-files
-                                (delete-duplicates
-                                 '#$(manifest-inputs manifest))))
+                    (append-map conf-files '#$inputs))
           (let ((success
                  (zero?
                   (system* (string-append #+ghc "/bin/ghc-pkg") "recache"
@@ -773,11 +779,10 @@ entries of MANIFEST, or #f if MANIFEST does not have any 
GHC packages."
             (for-each delete-file (find-files db-dir "\\.conf$"))
             (exit success)))))
 
-  (with-monad %store-monad
+  (mlet* %store-monad ((inputs interested))
     ;; Don't depend on GHC when there's nothing to do.
-    (if (any (cut string-prefix? "ghc" <>)
-             (map manifest-entry-name (manifest-entries manifest)))
-        (gexp->derivation "ghc-package-cache" build
+    (if (not (null? inputs))
+        (gexp->derivation "ghc-package-cache" (build inputs)
                           #:local-build? #t
                           #:substitutable? #f)
         (return #f))))
@@ -789,10 +794,17 @@ MANIFEST.  Single-file bundles are required by programs 
such as Git and Lynx."
   ;; See <http://lists.gnu.org/archive/html/guix-devel/2015-02/msg00429.html>
   ;; for a discussion.
 
+  (define interested
+    (eval-gexp
+     #~(filter
+        (lambda (input)
+          (file-exists? (string-append input "/etc/ssl/certs")))
+        '#$(manifest-inputs manifest))))
+
   (define glibc-utf8-locales                      ;lazy reference
     (module-ref (resolve-interface '(gnu packages base)) 'glibc-utf8-locales))
 
-  (define build
+  (define (build inputs)
     (with-imported-modules '((guix build utils))
       #~(begin
           (use-modules (guix build utils)
@@ -828,7 +840,7 @@ MANIFEST.  Single-file bundles are required by programs 
such as Git and Lynx."
                                  #+(package-version glibc-utf8-locales)))
           (setlocale LC_ALL "en_US.utf8")
 
-          (match (append-map ca-files '#$(manifest-inputs manifest))
+          (match (append-map ca-files '#$inputs)
             (()
              ;; Since there are no CA files, just create an empty directory.  
Do
              ;; not create the etc/ssl/certs sub-directory, since that would
@@ -844,9 +856,10 @@ MANIFEST.  Single-file bundles are required by programs 
such as Git and Lynx."
                                                  "/ca-certificates.crt"))
                #t))))))
 
-  (gexp->derivation "ca-certificate-bundle" build
-                    #:local-build? #t
-                    #:substitutable? #f))
+  (mlet* %store-monad ((inputs interested))
+    (gexp->derivation "ca-certificate-bundle" (build inputs)
+                      #:local-build? #t
+                      #:substitutable? #f)))
 
 (define (gtk-icon-themes manifest)
   "Return a derivation that unions all icon themes from manifest entries and
@@ -854,7 +867,15 @@ creates the GTK+ 'icon-theme.cache' file for each theme."
   (define gtk+  ; lazy reference
     (module-ref (resolve-interface '(gnu packages gtk)) 'gtk+))
 
-  (mlet %store-monad ((%gtk+ (manifest-lookup-package manifest "gtk+"))
+  (define interested
+    (eval-gexp
+     #~(filter
+        (lambda (input)
+          (file-exists? (string-append input "/share/icons")))
+        '#$(manifest-inputs manifest))))
+
+  (mlet %store-monad ((inputs interested)
+                      (%gtk+ (manifest-lookup-package manifest "gtk+"))
                       ;; XXX: Can't use gtk-update-icon-cache corresponding
                       ;; to the gtk+ referenced by 'manifest'.  Because
                       ;; '%gtk+' can be either a package or store path, and
@@ -877,9 +898,8 @@ creates the GTK+ 'icon-theme.cache' file for each theme."
                          (ice-9 ftw))
 
             (let* ((destdir  (string-append #$output "/share/icons"))
-                   (icondirs (filter file-exists?
-                                     (map (cut string-append <> "/share/icons")
-                                          '#$(manifest-inputs manifest)))))
+                   (icondirs (map (cut string-append <> "/share/icons")
+                                  '#$inputs)))
 
               ;; Union all the icons.
               (mkdir-p (string-append #$output "/share"))
@@ -907,8 +927,18 @@ creates the GTK+ 'icon-theme.cache' file for each theme."
 (define (gtk-im-modules manifest)
   "Return a derivation that builds the cache files for input method modules
 for both major versions of GTK+."
-
-  (mlet %store-monad ((gtk+   (manifest-lookup-package manifest "gtk+" "3"))
+  (define interested
+    (eval-gexp
+     (with-imported-modules '((guix build utils))
+       #~(begin
+           (use-modules (guix build utils))
+           (filter
+            (lambda (input)
+              (not (null? (find-files input "^immodules$" #:directories? #t))))
+            '#$(manifest-inputs manifest))))))
+
+  (mlet %store-monad ((inputs interested)
+                      (gtk+   (manifest-lookup-package manifest "gtk+" "3"))
                       (gtk+-2 (manifest-lookup-package manifest "gtk+" "2")))
 
     (define (build gtk gtk-version query)
@@ -932,7 +962,7 @@ for both major versions of GTK+."
                      (moddirs (cons (string-append #$gtk prefix "/immodules")
                                     (filter file-exists?
                                             (map (cut string-append <> prefix 
"/immodules")
-                                                 '#$(manifest-inputs 
manifest)))))
+                                                 '#$inputs))))
                      (modules (append-map (cut find-files <> "\\.so$")
                                           moddirs)))
 
@@ -980,11 +1010,19 @@ for both major versions of GTK+."
   "Return a derivation that builds the @file{mimeinfo.cache} database from
 desktop files.  It's used to query what applications can handle a given
 MIME type."
+  (define interested
+    (eval-gexp
+     #~(filter
+        (lambda (input)
+          (file-exists? (string-append input "/share/applications")))
+        '#$(manifest-inputs manifest))))
+
   (define desktop-file-utils            ; lazy reference
     (module-ref (resolve-interface '(gnu packages freedesktop))
                 'desktop-file-utils))
 
-  (mlet %store-monad ((glib
+  (mlet %store-monad ((inputs interested)
+                      (glib
                        (manifest-lookup-package
                         manifest "glib")))
     (define build
@@ -995,10 +1033,9 @@ MIME type."
                          (guix build utils)
                          (guix build union))
             (let* ((destdir (string-append #$output "/share/applications"))
-                   (appdirs (filter file-exists?
-                                    (map (cut string-append <>
-                                              "/share/applications")
-                                         '#$(manifest-inputs manifest))))
+                   (appdirs (map (cut string-append <>
+                                      "/share/applications")
+                                 '#$inputs))
                    (update-desktop-database (string-append
                                              #+desktop-file-utils
                                              "/bin/update-desktop-database")))
@@ -1017,10 +1054,18 @@ MIME type."
 (define (xdg-mime-database manifest)
   "Return a derivation that builds the @file{mime.cache} database from manifest
 entries.  It's used to query the MIME type of a given file."
+  (define interested
+    (eval-gexp
+     #~(filter
+        (lambda (input)
+          (file-exists? (string-append input "/share/mime/packages")))
+        '#$(manifest-inputs manifest))))
+
   (define shared-mime-info  ; lazy reference
     (module-ref (resolve-interface '(gnu packages gnome)) 'shared-mime-info))
 
-  (mlet %store-monad ((glib
+  (mlet %store-monad ((inputs interested)
+                      (glib
                        (manifest-lookup-package
                         manifest "glib")))
     (define build
@@ -1032,11 +1077,10 @@ entries.  It's used to query the MIME type of a given 
file."
                          (guix build union))
             (let* ((datadir (string-append #$output "/share"))
                    (destdir (string-append datadir "/mime"))
-                   (pkgdirs (filter file-exists?
-                                    (map (cut string-append <>
-                                              "/share/mime/packages")
-                                         (cons #+shared-mime-info
-                                               '#$(manifest-inputs 
manifest)))))
+                   (pkgdirs (map (cut string-append <>
+                                      "/share/mime/packages")
+                                 (cons #+shared-mime-info
+                                       '#$inputs)))
                    (update-mime-database (string-append
                                           #+shared-mime-info
                                           "/bin/update-mime-database")))
@@ -1059,21 +1103,27 @@ entries.  It's used to query the MIME type of a given 
file."
 (define (fonts-dir-file manifest)
   "Return a derivation that builds the @file{fonts.dir} and @file{fonts.scale}
 files for the fonts of the @var{manifest} entries."
+  (define interested
+    (eval-gexp
+     #~(filter
+        (lambda (input)
+          (file-exists? (string-append input "/share/fonts")))
+        '#$(manifest-inputs manifest))))
+
   (define mkfontscale
     (module-ref (resolve-interface '(gnu packages xorg)) 'mkfontscale))
 
   (define mkfontdir
     (module-ref (resolve-interface '(gnu packages xorg)) 'mkfontdir))
 
-  (define build
+  (define (build inputs)
     #~(begin
         (use-modules (srfi srfi-26)
                      (guix build utils)
                      (guix build union))
-        (let ((fonts-dirs (filter file-exists?
-                                  (map (cut string-append <>
-                                            "/share/fonts")
-                                       '#$(manifest-inputs manifest)))))
+        (let ((fonts-dirs (map (cut string-append <>
+                                    "/share/fonts")
+                               '#$inputs)))
           (mkdir #$output)
           (if (null? fonts-dirs)
               (exit #t)
@@ -1116,16 +1166,24 @@ files for the fonts of the @var{manifest} entries."
                                   (delete-file fonts-dir-file))))
                             directories)))))))
 
-  (gexp->derivation "fonts-dir" build
-                    #:modules '((guix build utils)
-                                (guix build union)
-                                (srfi srfi-26))
-                    #:local-build? #t
-                    #:substitutable? #f))
+  (mlet* %store-monad ((inputs interested))
+    (gexp->derivation "fonts-dir" (build inputs)
+                      #:modules '((guix build utils)
+                                  (guix build union)
+                                  (srfi srfi-26))
+                      #:local-build? #t
+                      #:substitutable? #f)))
 
 (define (manual-database manifest)
   "Return a derivation that builds the manual page database (\"mandb\") for
 the entries in MANIFEST."
+  (define interested
+    (eval-gexp
+     #~(filter
+        (lambda (input)
+          (file-exists? (string-append input "/share/man")))
+        '#$(manifest-inputs manifest))))
+
   (define gdbm-ffi
     (module-ref (resolve-interface '(gnu packages guile))
                 'guile-gdbm-ffi))
@@ -1148,7 +1206,7 @@ the entries in MANIFEST."
                   (source-module-closure `((guix build utils)
                                            (guix man-db))))))
 
-  (define build
+  (define (build inputs)
     (with-imported-modules modules
       #~(begin
           (add-to-load-path (string-append #$gdbm-ffi "/share/guile/site/"
@@ -1162,10 +1220,8 @@ the entries in MANIFEST."
           (define (compute-entries)
             (append-map (lambda (directory)
                           (let ((man (string-append directory "/share/man")))
-                            (if (directory-exists? man)
-                                (mandb-entries man)
-                                '())))
-                        '#$(manifest-inputs manifest)))
+                            (mandb-entries man)))
+                        '#$inputs))
 
           (define man-directory
             (string-append #$output "/share/man"))
@@ -1186,14 +1242,16 @@ the entries in MANIFEST."
                        (* (time-nanosecond duration) (expt 10 -9))))
             (force-output)))))
 
-  (gexp->derivation "manual-database" build
+  (mlet* %store-monad ((inputs interested))
+    (gexp->derivation
+     "manual-databased" (build inputs)
 
-                    ;; Work around GDBM 1.13 issue whereby uninitialized bytes
-                    ;; get written to disk:
-                    ;; 
<https://debbugs.gnu.org/cgi/bugreport.cgi?bug=29654#23>.
-                    #:env-vars `(("MALLOC_PERTURB_" . "1"))
+     ;; Work around GDBM 1.13 issue whereby uninitialized bytes get written to
+     ;; disk:
+     ;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=29654#23>.
+     #:env-vars `(("MALLOC_PERTURB_" . "1"))
 
-                    #:local-build? #t))
+     #:local-build? #t)))
 
 (define %default-profile-hooks
   ;; This is the list of derivation-returning procedures that are called by
-- 
2.13.3