Package: guix-patches;
Reported by: 宋文武 <iyzsong <at> member.fsf.org>
Date: Mon, 1 Jan 2018 10:34:08 UTC
Severity: normal
Tags: patch
Merged with 29925, 29926, 29927, 29928, 29929
Done: 宋文武 <iyzsong <at> outlook.com>
Bug is archived. No further changes may be made.
To add a comment to this bug, you must first unarchive it, by sending
a message to control AT debbugs.gnu.org, with unarchive 29930 in the body.
You can then email your comments to 29930 AT debbugs.gnu.org in the normal way.
Toggle the display of automated, internal messages from the tracker.
View this report as an mbox folder, status mbox, maintainer mbox
guix-patches <at> gnu.org:bug#29930; Package guix-patches.
(Mon, 01 Jan 2018 10:34:08 GMT) Full text and rfc822 format available.宋文武 <iyzsong <at> member.fsf.org>:guix-patches <at> gnu.org.
(Mon, 01 Jan 2018 10:34:08 GMT) Full text and rfc822 format available.Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):
From: 宋文武 <iyzsong <at> member.fsf.org> To: guix-patches <at> gnu.org Cc: 宋文武 <iyzsong <at> member.fsf.org> Subject: [PATCH 4/5] profiles: Filter out unwanted manifest entries for profile hooks. Date: Mon, 1 Jan 2018 18:33:35 +0800
* 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
ludo <at> gnu.org (Ludovic Courtès)
to control <at> debbugs.gnu.org.
(Wed, 07 Mar 2018 14:06:02 GMT) Full text and rfc822 format available.Leo Prikler <leo.prikler <at> student.tugraz.at>
to control <at> debbugs.gnu.org.
(Tue, 11 May 2021 13:36:02 GMT) Full text and rfc822 format available.Leo Prikler <leo.prikler <at> student.tugraz.at>
to control <at> debbugs.gnu.org.
(Tue, 11 May 2021 13:36:02 GMT) Full text and rfc822 format available.Debbugs Internal Request <help-debbugs <at> gnu.org>
to internal_control <at> debbugs.gnu.org.
(Wed, 09 Jun 2021 11:24:05 GMT) Full text and rfc822 format available.
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.