nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

profiles: Use 'with-imported-modules'. 

* guix/profiles.scm (info-dir-file): Use 'with-imported-modules' instead
of the #:module argument to 'gexp->derivation'.
(ghc-package-cache-file): Likewise.
(ca-certificate-bundle): Likewise.
(gtk-icon-themes): Likewise.
(xdg-desktop-database): Likewise.
(xdg-mime-database): Likewise.
(profile-derivation): Likewise.
This commit is contained in:
Ludovic Courtès 2016-07-12 00:54:22 +02:00
parent a91c3fc727
commit 99b231dee6
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 189 additions and 189 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

378
guix/profiles.scm
View File

@ -489,87 +489,87 @@ MANIFEST."
(module-ref (resolve-interface '(gnu packages compression)) 'gzip)) (module-ref (resolve-interface '(gnu packages compression)) 'gzip))
(define build (define build
#~(begin (with-imported-modules '((guix build utils))
(use-modules (guix build utils) #~(begin
(srfi srfi-1) (srfi srfi-26) (use-modules (guix build utils)
(ice-9 ftw)) (srfi srfi-1) (srfi srfi-26)
(ice-9 ftw))
(define (info-file? file) (define (info-file? file)
(or (string-suffix? ".info" file) (or (string-suffix? ".info" file)
(string-suffix? ".info.gz" file))) (string-suffix? ".info.gz" file)))
(define (info-files top) (define (info-files top)
(let ((infodir (string-append top "/share/info"))) (let ((infodir (string-append top "/share/info")))
(map (cut string-append infodir "/" <>) (map (cut string-append infodir "/" <>)
(or (scandir infodir info-file?) '())))) (or (scandir infodir info-file?) '()))))
(define (install-info info) (define (install-info info)
(setenv "PATH" (string-append #+gzip "/bin")) ;for info.gz files (setenv "PATH" (string-append #+gzip "/bin")) ;for info.gz files
(zero? (zero?
(system* (string-append #+texinfo "/bin/install-info") "--silent" (system* (string-append #+texinfo "/bin/install-info") "--silent"
info (string-append #$output "/share/info/dir")))) info (string-append #$output "/share/info/dir"))))
(mkdir-p (string-append #$output "/share/info")) (mkdir-p (string-append #$output "/share/info"))
(exit (every install-info (exit (every install-info
(append-map info-files (append-map info-files
'#$(manifest-inputs manifest)))))) '#$(manifest-inputs manifest)))))))
(gexp->derivation "info-dir" build (gexp->derivation "info-dir" build
#:modules '((guix build utils))
#:local-build? #t #:local-build? #t
#:substitutable? #f)) #:substitutable? #f))
(define (ghc-package-cache-file manifest) (define (ghc-package-cache-file manifest)
"Return a derivation that builds the GHC 'package.cache' file for all the "Return a derivation that builds the GHC 'package.cache' file for all the
entries of MANIFEST, or #f if MANIFEST does not have any GHC packages." entries of MANIFEST, or #f if MANIFEST does not have any GHC packages."
(define ghc ;lazy reference (define ghc ;lazy reference
(module-ref (resolve-interface '(gnu packages haskell)) 'ghc)) (module-ref (resolve-interface '(gnu packages haskell)) 'ghc))
(define build (define build
#~(begin (with-imported-modules '((guix build utils))
(use-modules (guix build utils) #~(begin
(srfi srfi-1) (srfi srfi-26) (use-modules (guix build utils)
(ice-9 ftw)) (srfi srfi-1) (srfi srfi-26)
(ice-9 ftw))
(define ghc-name-version (define ghc-name-version
(let* ((base (basename #+ghc))) (let* ((base (basename #+ghc)))
(string-drop base (string-drop base
(+ 1 (string-index base #\-))))) (+ 1 (string-index base #\-)))))
(define db-subdir (define db-subdir
(string-append "lib/" ghc-name-version "/package.conf.d")) (string-append "lib/" ghc-name-version "/package.conf.d"))
(define db-dir (define db-dir
(string-append #$output "/" db-subdir)) (string-append #$output "/" db-subdir))
(define (conf-files top) (define (conf-files top)
(let ((db (string-append top "/" db-subdir))) (let ((db (string-append top "/" db-subdir)))
(if (file-exists? db) (if (file-exists? db)
(find-files db "\\.conf$") (find-files db "\\.conf$")
'()))) '())))
(define (copy-conf-file conf) (define (copy-conf-file conf)
(let ((base (basename conf))) (let ((base (basename conf)))
(copy-file conf (string-append db-dir "/" base)))) (copy-file conf (string-append db-dir "/" base))))
(system* (string-append #+ghc "/bin/ghc-pkg") "init" db-dir) (system* (string-append #+ghc "/bin/ghc-pkg") "init" db-dir)
(for-each copy-conf-file (for-each copy-conf-file
(append-map conf-files (append-map conf-files
(delete-duplicates (delete-duplicates
'#$(manifest-inputs manifest)))) '#$(manifest-inputs manifest))))
(let ((success (let ((success
(zero? (zero?
(system* (string-append #+ghc "/bin/ghc-pkg") "recache" (system* (string-append #+ghc "/bin/ghc-pkg") "recache"
(string-append "--package-db=" db-dir))))) (string-append "--package-db=" db-dir)))))
(for-each delete-file (find-files db-dir "\\.conf$")) (for-each delete-file (find-files db-dir "\\.conf$"))
(exit success)))) (exit success)))))
(with-monad %store-monad (with-monad %store-monad
;; Don't depend on GHC when there's nothing to do. ;; Don't depend on GHC when there's nothing to do.
(if (any (cut string-prefix? "ghc" <>) (if (any (cut string-prefix? "ghc" <>)
(map manifest-entry-name (manifest-entries manifest))) (map manifest-entry-name (manifest-entries manifest)))
(gexp->derivation "ghc-package-cache" build (gexp->derivation "ghc-package-cache" build
#:modules '((guix build utils))
#:local-build? #t #:local-build? #t
#:substitutable? #f) #:substitutable? #f)
(return #f)))) (return #f))))
@ -585,58 +585,58 @@ MANIFEST. Single-file bundles are required by programs such as Git and Lynx."
(module-ref (resolve-interface '(gnu packages base)) 'glibc-utf8-locales)) (module-ref (resolve-interface '(gnu packages base)) 'glibc-utf8-locales))
(define build (define build
#~(begin (with-imported-modules '((guix build utils))
(use-modules (guix build utils) #~(begin
(rnrs io ports) (use-modules (guix build utils)
(srfi srfi-1) (rnrs io ports)
(srfi srfi-26) (srfi srfi-1)
(ice-9 ftw) (srfi srfi-26)
(ice-9 match)) (ice-9 ftw)
(ice-9 match))
(define (pem-file? file) (define (pem-file? file)
(string-suffix? ".pem" file)) (string-suffix? ".pem" file))
(define (ca-files top) (define (ca-files top)
(let ((cert-dir (string-append top "/etc/ssl/certs"))) (let ((cert-dir (string-append top "/etc/ssl/certs")))
(map (cut string-append cert-dir "/" <>) (map (cut string-append cert-dir "/" <>)
(or (scandir cert-dir pem-file?) '())))) (or (scandir cert-dir pem-file?) '()))))
(define (concatenate-files files result) (define (concatenate-files files result)
"Make RESULT the concatenation of all of FILES." "Make RESULT the concatenation of all of FILES."
(define (dump file port) (define (dump file port)
(display (call-with-input-file file get-string-all) (display (call-with-input-file file get-string-all)
port) port)
(newline port)) ;required, see <https://bugs.debian.org/635570> (newline port)) ;required, see <https://bugs.debian.org/635570>
(call-with-output-file result (call-with-output-file result
(lambda (port) (lambda (port)
(for-each (cut dump <> port) files)))) (for-each (cut dump <> port) files))))
;; Some file names in the NSS certificates are UTF-8 encoded so ;; Some file names in the NSS certificates are UTF-8 encoded so
;; install a UTF-8 locale. ;; install a UTF-8 locale.
(setenv "LOCPATH" (setenv "LOCPATH"
(string-append #+glibc-utf8-locales "/lib/locale/" (string-append #+glibc-utf8-locales "/lib/locale/"
#+(package-version glibc-utf8-locales))) #+(package-version glibc-utf8-locales)))
(setlocale LC_ALL "en_US.utf8") (setlocale LC_ALL "en_US.utf8")
(match (append-map ca-files '#$(manifest-inputs manifest)) (match (append-map ca-files '#$(manifest-inputs manifest))
(() (()
;; Since there are no CA files, just create an empty directory. Do ;; Since there are no CA files, just create an empty directory. Do
;; not create the etc/ssl/certs sub-directory, since that would ;; not create the etc/ssl/certs sub-directory, since that would
;; wrongfully lead to a message about 'SSL_CERT_DIR' needing to be ;; wrongfully lead to a message about 'SSL_CERT_DIR' needing to be
;; defined. ;; defined.
(mkdir #$output) (mkdir #$output)
#t) #t)
((ca-files ...) ((ca-files ...)
(let ((result (string-append #$output "/etc/ssl/certs"))) (let ((result (string-append #$output "/etc/ssl/certs")))
(mkdir-p result) (mkdir-p result)
(concatenate-files ca-files (concatenate-files ca-files
(string-append result (string-append result
"/ca-certificates.crt")) "/ca-certificates.crt"))
#t))))) #t))))))
(gexp->derivation "ca-certificate-bundle" build (gexp->derivation "ca-certificate-bundle" build
#:modules '((guix build utils))
#:local-build? #t #:local-build? #t
#:substitutable? #f)) #:substitutable? #f))
@ -645,44 +645,44 @@ MANIFEST. Single-file bundles are required by programs such as Git and Lynx."
creates the GTK+ 'icon-theme.cache' file for each theme." creates the GTK+ 'icon-theme.cache' file for each theme."
(mlet %store-monad ((gtk+ (manifest-lookup-package manifest "gtk+"))) (mlet %store-monad ((gtk+ (manifest-lookup-package manifest "gtk+")))
(define build (define build
#~(begin (with-imported-modules '((guix build utils)
(use-modules (guix build utils) (guix build union)
(guix build union) (guix build profiles)
(guix build profiles) (guix search-paths)
(srfi srfi-26) (guix records))
(ice-9 ftw)) #~(begin
(use-modules (guix build utils)
(guix build union)
(guix build profiles)
(srfi srfi-26)
(ice-9 ftw))
(let* ((destdir (string-append #$output "/share/icons")) (let* ((destdir (string-append #$output "/share/icons"))
(icondirs (filter file-exists? (icondirs (filter file-exists?
(map (cut string-append <> "/share/icons") (map (cut string-append <> "/share/icons")
'#$(manifest-inputs manifest)))) '#$(manifest-inputs manifest))))
(update-icon-cache (string-append (update-icon-cache (string-append
#+gtk+ "/bin/gtk-update-icon-cache"))) #+gtk+ "/bin/gtk-update-icon-cache")))
;; Union all the icons. ;; Union all the icons.
(mkdir-p (string-append #$output "/share")) (mkdir-p (string-append #$output "/share"))
(union-build destdir icondirs (union-build destdir icondirs
#:log-port (%make-void-port "w")) #:log-port (%make-void-port "w"))
;; Update the 'icon-theme.cache' file for each icon theme. ;; Update the 'icon-theme.cache' file for each icon theme.
(for-each (for-each
(lambda (theme) (lambda (theme)
(let ((dir (string-append destdir "/" theme))) (let ((dir (string-append destdir "/" theme)))
;; Occasionally DESTDIR contains plain files, such as ;; Occasionally DESTDIR contains plain files, such as
;; "abiword_48.png". Ignore these. ;; "abiword_48.png". Ignore these.
(when (file-is-directory? dir) (when (file-is-directory? dir)
(ensure-writable-directory dir) (ensure-writable-directory dir)
(system* update-icon-cache "-t" dir "--quiet")))) (system* update-icon-cache "-t" dir "--quiet"))))
(scandir destdir (negate (cut member <> '("." "..")))))))) (scandir destdir (negate (cut member <> '("." "..")))))))))
;; Don't run the hook when there's nothing to do. ;; Don't run the hook when there's nothing to do.
(if gtk+ (if gtk+
(gexp->derivation "gtk-icon-themes" build (gexp->derivation "gtk-icon-themes" build
#:modules '((guix build utils)
(guix build union)
(guix build profiles)
(guix search-paths)
(guix records))
#:local-build? #t #:local-build? #t
#:substitutable? #f) #:substitutable? #f)
(return #f)))) (return #f))))
@ -695,28 +695,28 @@ MIME type."
(manifest-lookup-package (manifest-lookup-package
manifest "desktop-file-utils"))) manifest "desktop-file-utils")))
(define build (define build
#~(begin (with-imported-modules '((guix build utils)
(use-modules (srfi srfi-26) (guix build union))
(guix build utils) #~(begin
(guix build union)) (use-modules (srfi srfi-26)
(let* ((destdir (string-append #$output "/share/applications")) (guix build utils)
(appdirs (filter file-exists? (guix build union))
(map (cut string-append <> (let* ((destdir (string-append #$output "/share/applications"))
"/share/applications") (appdirs (filter file-exists?
'#$(manifest-inputs manifest)))) (map (cut string-append <>
(update-desktop-database (string-append "/share/applications")
#+desktop-file-utils '#$(manifest-inputs manifest))))
"/bin/update-desktop-database"))) (update-desktop-database (string-append
(mkdir-p (string-append #$output "/share")) #+desktop-file-utils
(union-build destdir appdirs "/bin/update-desktop-database")))
#:log-port (%make-void-port "w")) (mkdir-p (string-append #$output "/share"))
(exit (zero? (system* update-desktop-database destdir)))))) (union-build destdir appdirs
#:log-port (%make-void-port "w"))
(exit (zero? (system* update-desktop-database destdir)))))))
;; Don't run the hook when 'desktop-file-utils' is not referenced. ;; Don't run the hook when 'desktop-file-utils' is not referenced.
(if desktop-file-utils (if desktop-file-utils
(gexp->derivation "xdg-desktop-database" build (gexp->derivation "xdg-desktop-database" build
#:modules '((guix build utils)
(guix build union))
#:local-build? #t #:local-build? #t
#:substitutable? #f) #:substitutable? #f)
(return #f)))) (return #f))))
@ -728,30 +728,30 @@ entries. It's used to query the MIME type of a given file."
(manifest-lookup-package (manifest-lookup-package
manifest "shared-mime-info"))) manifest "shared-mime-info")))
(define build (define build
#~(begin (with-imported-modules '((guix build utils)
(use-modules (srfi srfi-26) (guix build union))
(guix build utils) #~(begin
(guix build union)) (use-modules (srfi srfi-26)
(let* ((datadir (string-append #$output "/share")) (guix build utils)
(destdir (string-append datadir "/mime")) (guix build union))
(pkgdirs (filter file-exists? (let* ((datadir (string-append #$output "/share"))
(map (cut string-append <> (destdir (string-append datadir "/mime"))
"/share/mime/packages") (pkgdirs (filter file-exists?
'#$(manifest-inputs manifest)))) (map (cut string-append <>
(update-mime-database (string-append "/share/mime/packages")
#+shared-mime-info '#$(manifest-inputs manifest))))
"/bin/update-mime-database"))) (update-mime-database (string-append
(mkdir-p destdir) #+shared-mime-info
(union-build (string-append destdir "/packages") pkgdirs "/bin/update-mime-database")))
#:log-port (%make-void-port "w")) (mkdir-p destdir)
(setenv "XDG_DATA_HOME" datadir) (union-build (string-append destdir "/packages") pkgdirs
(exit (zero? (system* update-mime-database destdir)))))) #:log-port (%make-void-port "w"))
(setenv "XDG_DATA_HOME" datadir)
(exit (zero? (system* update-mime-database destdir)))))))
;; Don't run the hook when 'shared-mime-info' is referenced. ;; Don't run the hook when 'shared-mime-info' is referenced.
(if shared-mime-info (if shared-mime-info
(gexp->derivation "xdg-mime-database" build (gexp->derivation "xdg-mime-database" build
#:modules '((guix build utils)
(guix build union))
#:local-build? #t #:local-build? #t
#:substitutable? #f) #:substitutable? #f)
(return #f)))) (return #f))))
@ -790,34 +790,34 @@ the monadic procedures listed in HOOKS--such as an Info 'dir' file, etc."
(manifest-inputs manifest))) (manifest-inputs manifest)))
(define builder (define builder
#~(begin (with-imported-modules '((guix build profiles)
(use-modules (guix build profiles) (guix build union)
(guix search-paths) (guix build utils)
(srfi srfi-1)) (guix search-paths)
(guix records))
#~(begin
(use-modules (guix build profiles)
(guix search-paths)
(srfi srfi-1))
(setvbuf (current-output-port) _IOLBF) (setvbuf (current-output-port) _IOLBF)
(setvbuf (current-error-port) _IOLBF) (setvbuf (current-error-port) _IOLBF)
(define search-paths (define search-paths
;; Search paths of MANIFEST's packages, converted back to their ;; Search paths of MANIFEST's packages, converted back to their
;; record form. ;; record form.
(map sexp->search-path-specification (map sexp->search-path-specification
(delete-duplicates (delete-duplicates
'#$(map search-path-specification->sexp '#$(map search-path-specification->sexp
(append-map manifest-entry-search-paths (append-map manifest-entry-search-paths
(manifest-entries manifest)))))) (manifest-entries manifest))))))
(build-profile #$output '#$inputs (build-profile #$output '#$inputs
#:manifest '#$(manifest->gexp manifest) #:manifest '#$(manifest->gexp manifest)
#:search-paths search-paths))) #:search-paths search-paths))))
(gexp->derivation "profile" builder (gexp->derivation "profile" builder
#:system system #:system system
#:modules '((guix build profiles)
(guix build union)
(guix build utils)
(guix search-paths)
(guix records))
;; Not worth offloading. ;; Not worth offloading.
#:local-build? #t #:local-build? #t