From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:4830:134:3::10]:48931) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1eVxQ2-0006Pu-L5 for guix-patches@gnu.org; Mon, 01 Jan 2018 05:34:12 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1eVxQ0-0004Xw-O3 for guix-patches@gnu.org; Mon, 01 Jan 2018 05:34:10 -0500 Received: from debbugs.gnu.org ([208.118.235.43]:50588) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1eVxQ0-0004Xj-K3 for guix-patches@gnu.org; Mon, 01 Jan 2018 05:34:08 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1eVxQ0-0000vO-D6 for guix-patches@gnu.org; Mon, 01 Jan 2018 05:34:08 -0500 Subject: [bug#29930] [PATCH 4/5] profiles: Filter out unwanted manifest entries for profile hooks. Resent-Message-ID: Received: from eggs.gnu.org ([2001:4830:134:3::10]:48757) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1eVxPj-0006LK-7f for guix-patches@gnu.org; Mon, 01 Jan 2018 05:33:53 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1eVxPh-0004O8-8p for guix-patches@gnu.org; Mon, 01 Jan 2018 05:33:51 -0500 Received: from rezeros.cc ([45.76.207.221]:56206) by eggs.gnu.org with esmtps (TLS1.0:DHE_RSA_AES_256_CBC_SHA1:32) (Exim 4.71) (envelope-from ) id 1eVxPg-0004LU-PN for guix-patches@gnu.org; Mon, 01 Jan 2018 05:33:49 -0500 From: =?UTF-8?Q?=E5=AE=8B=E6=96=87=E6=AD=A6?= Date: Mon, 1 Jan 2018 18:33:35 +0800 Message-Id: <20180101103336.8613-5-iyzsong@member.fsf.org> In-Reply-To: <20180101103336.8613-1-iyzsong@member.fsf.org> References: <20180101103336.8613-1-iyzsong@member.fsf.org> List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+kyle=kyleam.com@gnu.org Sender: "Guix-patches" To: 29930@debbugs.gnu.org * 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 ;; 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: - ;; . - #:env-vars `(("MALLOC_PERTURB_" . "1")) + ;; Work around GDBM 1.13 issue whereby uninitialized bytes get written to + ;; disk: + ;; . + #: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