;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com>
-;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2016, 2018, 2019 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 © 2019 Kyle Meyer <kyle@kyleam.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix profiles)
+ #:use-module ((guix config) #:select (%state-directory))
#:use-module ((guix utils) #:hide (package-name->name+version))
#:use-module ((guix build utils)
- #:select (package-name->name+version))
+ #:select (package-name->name+version mkdir-p))
+ #:use-module (guix i18n)
#:use-module (guix records)
#:use-module (guix packages)
#:use-module (guix derivations)
#:use-module (guix search-paths)
#:use-module (guix gexp)
+ #:use-module (guix modules)
#:use-module (guix monads)
#:use-module (guix store)
+ #:use-module (guix sets)
+ #:use-module (ice-9 vlist)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (ice-9 ftw)
profile-error-profile
&profile-not-found-error
profile-not-found-error?
+ &profile-collision-error
+ profile-collision-error?
+ profile-collision-error-entry
+ profile-collision-error-conflict
&missing-generation-error
missing-generation-error?
missing-generation-error-generation
+ &unmatched-pattern-error
+ unmatched-pattern-error?
+ unmatched-pattern-error-pattern
+ unmatched-pattern-error-manifest
manifest make-manifest
manifest?
manifest-entries
+ manifest-transitive-entries
<manifest-entry> ; FIXME: eventually make it internal
manifest-entry
manifest-entry-item
manifest-entry-dependencies
manifest-entry-search-paths
+ manifest-entry-parent
+ manifest-entry-properties
manifest-pattern
manifest-pattern?
manifest-lookup
manifest-installed?
manifest-matching-entries
+ manifest-search-paths
manifest-transaction
manifest-transaction?
manifest-transaction-install-entry
manifest-transaction-remove-pattern
manifest-transaction-null?
+ manifest-transaction-removal-candidate?
manifest-perform-transaction
manifest-transaction-effects
ca-certificate-bundle
%default-profile-hooks
profile-derivation
+ profile-search-paths
generation-number
+ generation-profile
generation-numbers
profile-generations
relative-generation-spec->number
generation-file-name
switch-to-generation
roll-back
- delete-generation))
+ delete-generation
+
+ %user-profile-directory
+ %profile-directory
+ %current-profile
+ ensure-profile-directory
+ canonicalize-profile
+ user-friendly-profile))
;;; Commentary:
;;;
(define-condition-type &profile-not-found-error &profile-error
profile-not-found-error?)
+(define-condition-type &profile-collision-error &error
+ profile-collision-error?
+ (entry profile-collision-error-entry) ;<manifest-entry>
+ (conflict profile-collision-error-conflict)) ;<manifest-entry>
+
+(define-condition-type &unmatched-pattern-error &error
+ unmatched-pattern-error?
+ (pattern unmatched-pattern-error-pattern) ;<manifest-pattern>
+ (manifest unmatched-pattern-error-manifest)) ;<manifest>
+
(define-condition-type &missing-generation-error &profile-error
missing-generation-error?
(generation missing-generation-error-generation))
(version manifest-entry-version) ; string
(output manifest-entry-output ; string
(default "out"))
- (item manifest-entry-item) ; package | store path
- (dependencies manifest-entry-dependencies ; (store path | package)*
+ (item manifest-entry-item) ; package | file-like | store path
+ (dependencies manifest-entry-dependencies ; <manifest-entry>*
(default '()))
(search-paths manifest-entry-search-paths ; search-path-specification*
+ (default '()))
+ (parent manifest-entry-parent ; promise (#f | <manifest-entry>)
+ (default (delay #f)))
+ (properties manifest-entry-properties ; list of symbol/value pairs
(default '())))
(define-record-type* <manifest-pattern> manifest-pattern
(output manifest-pattern-output ; string | #f
(default "out")))
+(define (manifest-transitive-entries manifest)
+ "Return the entries of MANIFEST along with their propagated inputs,
+recursively."
+ (let loop ((entries (manifest-entries manifest))
+ (result '())
+ (visited (set))) ;compare with 'equal?'
+ (match entries
+ (()
+ (reverse result))
+ ((head . tail)
+ (if (set-contains? visited head)
+ (loop tail result visited)
+ (loop (append (manifest-entry-dependencies head)
+ tail)
+ (cons head result)
+ (set-insert head visited)))))))
+
(define (profile-manifest profile)
"Return the PROFILE's manifest."
(let ((file (string-append profile "/manifest")))
(call-with-input-file file read-manifest)
(manifest '()))))
-(define* (package->manifest-entry package #:optional (output "out"))
+(define (manifest-entry-lookup manifest)
+ "Return a lookup procedure for the entries of MANIFEST. The lookup
+procedure takes two arguments: the entry name and output."
+ (define mapping
+ (let loop ((entries (manifest-entries manifest))
+ (mapping vlist-null))
+ (fold (lambda (entry result)
+ (vhash-cons (cons (manifest-entry-name entry)
+ (manifest-entry-output entry))
+ entry
+ (loop (manifest-entry-dependencies entry)
+ result)))
+ mapping
+ entries)))
+
+ (lambda (name output)
+ (match (vhash-assoc (cons name output) mapping)
+ ((_ . entry) entry)
+ (#f #f))))
+
+(define* (lower-manifest-entry entry system #:key target)
+ "Lower ENTRY for SYSTEM and TARGET such that its 'item' field is a store
+file name."
+ (let ((item (manifest-entry-item entry)))
+ (if (string? item)
+ (with-monad %store-monad
+ (return entry))
+ (mlet %store-monad ((drv (lower-object item system
+ #:target target))
+ (output -> (manifest-entry-output entry)))
+ (return (manifest-entry
+ (inherit entry)
+ (item (derivation->output-path drv output))))))))
+
+(define* (check-for-collisions manifest system #:key target)
+ "Check whether the entries of MANIFEST conflict with one another; raise a
+'&profile-collision-error' when a conflict is encountered."
+ (define lookup
+ (manifest-entry-lookup manifest))
+
+ (with-monad %store-monad
+ (foldm %store-monad
+ (lambda (entry result)
+ (match (lookup (manifest-entry-name entry)
+ (manifest-entry-output entry))
+ ((? manifest-entry? second) ;potential conflict
+ (mlet %store-monad ((first (lower-manifest-entry entry system
+ #:target
+ target))
+ (second (lower-manifest-entry second system
+ #:target
+ target)))
+ (if (string=? (manifest-entry-item first)
+ (manifest-entry-item second))
+ (return result)
+ (raise (condition
+ (&profile-collision-error
+ (entry first)
+ (conflict second)))))))
+ (#f ;no conflict
+ (return result))))
+ #t
+ (manifest-transitive-entries manifest))))
+
+(define* (package->manifest-entry package #:optional (output "out")
+ #:key (parent (delay #f))
+ (properties '()))
"Return a manifest entry for the OUTPUT of package PACKAGE."
- (let ((deps (map (match-lambda
- ((label package)
- (gexp-input package))
- ((label package output)
- (gexp-input package output)))
- (package-transitive-propagated-inputs package))))
- (manifest-entry
- (name (package-name package))
- (version (package-version package))
- (output output)
- (item package)
- (dependencies (delete-duplicates deps))
- (search-paths (package-transitive-native-search-paths package)))))
+ ;; For each dependency, keep a promise pointing to its "parent" entry.
+ (letrec* ((deps (map (match-lambda
+ ((label package)
+ (package->manifest-entry package
+ #:parent (delay entry)))
+ ((label package output)
+ (package->manifest-entry package output
+ #:parent (delay entry))))
+ (package-propagated-inputs package)))
+ (entry (manifest-entry
+ (name (package-name package))
+ (version (package-version package))
+ (output output)
+ (item package)
+ (dependencies (delete-duplicates deps))
+ (search-paths
+ (package-transitive-native-search-paths package))
+ (parent parent)
+ (properties properties))))
+ entry))
(define (packages->manifest packages)
"Return a list of manifest entries, one for each item listed in PACKAGES.
Elements of PACKAGES can be either package objects or package/string tuples
denoting a specific output of a package."
+ (define inferiors-loaded?
+ ;; This hack allows us to provide seamless integration for inferior
+ ;; packages while not having a hard dependency on (guix inferior).
+ (resolve-module '(guix inferior) #f #f #:ensure #f))
+
+ (define (inferior->entry)
+ (module-ref (resolve-interface '(guix inferior))
+ 'inferior-package->manifest-entry))
+
(manifest
(map (match-lambda
- ((package output)
- (package->manifest-entry package output))
- ((? package? package)
- (package->manifest-entry package)))
+ (((? package? package) output)
+ (package->manifest-entry package output))
+ ((? package? package)
+ (package->manifest-entry package))
+ ((thing output)
+ (if inferiors-loaded?
+ ((inferior->entry) thing output)
+ (throw 'wrong-type-arg 'packages->manifest
+ "Wrong package object: ~S" (list thing) (list thing))))
+ (thing
+ (if inferiors-loaded?
+ ((inferior->entry) thing)
+ (throw 'wrong-type-arg 'packages->manifest
+ "Wrong package object: ~S" (list thing) (list thing)))))
packages)))
(define (manifest->gexp manifest)
(define (entry->gexp entry)
(match entry
(($ <manifest-entry> name version output (? string? path)
- (deps ...) (search-paths ...))
+ (deps ...) (search-paths ...) _ (properties ...))
#~(#$name #$version #$output #$path
- (propagated-inputs #$deps)
+ (propagated-inputs #$(map entry->gexp deps))
(search-paths #$(map search-path-specification->sexp
- search-paths))))
- (($ <manifest-entry> name version output (? package? package)
- (deps ...) (search-paths ...))
+ search-paths))
+ (properties . #$properties)))
+ (($ <manifest-entry> name version output package
+ (deps ...) (search-paths ...) _ (properties ...))
#~(#$name #$version #$output
(ungexp package (or output "out"))
- (propagated-inputs #$deps)
+ (propagated-inputs #$(map entry->gexp deps))
(search-paths #$(map search-path-specification->sexp
- search-paths))))))
+ search-paths))
+ (properties . #$properties)))))
(match manifest
(($ <manifest> (entries ...))
- #~(manifest (version 2)
+ #~(manifest (version 3)
(packages #$(map entry->gexp entries))))))
(define (find-package name version)
(package-native-search-paths package)
'())))
+ (define (infer-dependency item parent)
+ ;; Return a <manifest-entry> for ITEM.
+ (let-values (((name version)
+ (package-name->name+version
+ (store-path-package-name item))))
+ (manifest-entry
+ (name name)
+ (version version)
+ (item item)
+ (parent parent))))
+
+ (define* (sexp->manifest-entry sexp #:optional (parent (delay #f)))
+ (match sexp
+ ((name version output path
+ ('propagated-inputs deps)
+ ('search-paths search-paths)
+ extra-stuff ...)
+ ;; For each of DEPS, keep a promise pointing to ENTRY.
+ (letrec* ((deps* (map (cut sexp->manifest-entry <> (delay entry))
+ deps))
+ (entry (manifest-entry
+ (name name)
+ (version version)
+ (output output)
+ (item path)
+ (dependencies deps*)
+ (search-paths (map sexp->search-path-specification
+ search-paths))
+ (parent parent)
+ (properties (or (assoc-ref extra-stuff 'properties)
+ '())))))
+ entry))))
+
(match sexp
(('manifest ('version 0)
('packages ((name version output path) ...)))
(manifest
(map (lambda (name version output path)
(manifest-entry
- (name name)
- (version version)
- (output output)
- (item path)
- (search-paths (infer-search-paths name version))))
+ (name name)
+ (version version)
+ (output output)
+ (item path)
+ (search-paths (infer-search-paths name version))))
name version output path)))
;; Version 1 adds a list of propagated inputs to the
directories)
((directories ...)
directories))))
- (manifest-entry
- (name name)
- (version version)
- (output output)
- (item path)
- (dependencies deps)
- (search-paths (infer-search-paths name version)))))
+ (letrec* ((deps* (map (cute infer-dependency <> (delay entry))
+ deps))
+ (entry (manifest-entry
+ (name name)
+ (version version)
+ (output output)
+ (item path)
+ (dependencies deps*)
+ (search-paths
+ (infer-search-paths name version)))))
+ entry)))
name version output path deps)))
;; Version 2 adds search paths and is slightly more verbose.
...)))
(manifest
(map (lambda (name version output path deps search-paths)
- (manifest-entry
- (name name)
- (version version)
- (output output)
- (item path)
- (dependencies deps)
- (search-paths (map sexp->search-path-specification
- search-paths))))
+ (letrec* ((deps* (map (cute infer-dependency <> (delay entry))
+ deps))
+ (entry (manifest-entry
+ (name name)
+ (version version)
+ (output output)
+ (item path)
+ (dependencies deps*)
+ (search-paths
+ (map sexp->search-path-specification
+ search-paths)))))
+ entry))
name version output path deps search-paths)))
+
+ ;; Version 3 represents DEPS as full-blown manifest entries.
+ (('manifest ('version 3 minor-version ...)
+ ('packages (entries ...)))
+ (manifest (map sexp->manifest-entry entries)))
(_
(raise (condition
(&message (message "unsupported manifest format")))))))
Remove MANIFEST entries that have the same name and output as ENTRIES."
(define (same-entry? entry name output)
(match entry
- (($ <manifest-entry> entry-name _ entry-output _ ...)
+ (($ <manifest-entry> entry-name _ entry-output _)
(and (equal? name entry-name)
(equal? output entry-output)))))
(make-manifest
- (append entries
- (fold (lambda (entry result)
- (match entry
- (($ <manifest-entry> name _ out _ ...)
- (filter (negate (cut same-entry? <> name out))
- result))))
- (manifest-entries manifest)
- entries))))
+ (fold (lambda (entry result) ;XXX: quadratic
+ (match entry
+ (($ <manifest-entry> name _ out _)
+ (cons entry
+ (remove (cut same-entry? <> name out)
+ result)))))
+ (manifest-entries manifest)
+ entries)))
(define (manifest-lookup manifest pattern)
"Return the first item of MANIFEST that matches PATTERN, or #f if there is
(->bool (manifest-lookup manifest pattern)))
(define (manifest-matching-entries manifest patterns)
- "Return all the entries of MANIFEST that match one of the PATTERNS."
- (define predicates
- (map entry-predicate patterns))
-
- (define (matches? entry)
- (any (lambda (pred)
- (pred entry))
- predicates))
-
- (filter matches? (manifest-entries manifest)))
+ "Return all the entries of MANIFEST that match one of the PATTERNS. Raise
+an '&unmatched-pattern-error' if none of the entries of MANIFEST matches one
+of PATTERNS."
+ (fold-right (lambda (pattern matches)
+ (match (filter (entry-predicate pattern)
+ (manifest-entries manifest))
+ (()
+ (raise (condition
+ (&unmatched-pattern-error
+ (pattern pattern)
+ (manifest manifest)))))
+ (lst
+ (append lst matches))))
+ '()
+ patterns))
+
+(define (manifest-search-paths manifest)
+ "Return the list of search path specifications that apply to MANIFEST,
+including the search path specification for $PATH."
+ (delete-duplicates
+ (cons $PATH
+ (append-map manifest-entry-search-paths
+ (manifest-entries manifest)))))
\f
;;;
(($ <manifest-transaction> () ()) #t)
(($ <manifest-transaction> _ _) #f)))
+(define (manifest-transaction-removal-candidate? entry transaction)
+ "Return true if ENTRY is a candidate for removal in TRANSACTION."
+ (any (lambda (pattern)
+ ((entry-predicate pattern) entry))
+ (manifest-transaction-remove transaction)))
+
(define (manifest-transaction-effects manifest transaction)
"Compute the effect of applying TRANSACTION to MANIFEST. Return 4 values:
the list of packages that would be removed, installed, upgraded, or downgraded
(define (manifest-inputs manifest)
"Return a list of <gexp-input> objects for MANIFEST."
- (append-map (match-lambda
- (($ <manifest-entry> name version output thing deps)
- ;; THING may be a package or a file name. In the latter case,
- ;; assume it's already valid. Ditto for DEPS.
- (cons (gexp-input thing output) deps)))
- (manifest-entries manifest)))
+ (define entry->input
+ (match-lambda
+ (($ <manifest-entry> name version output thing deps)
+ ;; THING may be a package or a file name. In the latter case, assume
+ ;; it's already valid.
+ (cons (gexp-input thing output)
+ (append-map entry->input deps)))))
+
+ (append-map entry->input (manifest-entries manifest)))
(define* (manifest-lookup-package manifest name #:optional version)
"Return as a monadic value the first package or store path referenced by
(return (find-among-inputs inputs)))))
((? string? item)
(mlet %store-monad ((refs (references* item)))
- (return (find-among-store-items refs)))))))
+ (return (find-among-store-items refs))))
+ (item
+ ;; XXX: ITEM might be a 'computed-file' or anything like that, in
+ ;; which case we don't know what to do. The fix may be to check
+ ;; references once ITEM is compiled, as proposed at
+ ;; <https://bugs.gnu.org/29927>.
+ (return #f)))))
(anym %store-monad
entry-lookup-package (manifest-entries manifest)))
(module-ref (resolve-interface '(gnu packages texinfo)) 'texinfo))
(define gzip ;lazy reference
(module-ref (resolve-interface '(gnu packages compression)) 'gzip))
+ (define glibc-utf8-locales ;lazy reference
+ (module-ref (resolve-interface '(gnu packages base)) 'glibc-utf8-locales))
(define build
(with-imported-modules '((guix build utils))
(map (cut string-append infodir "/" <>)
(or (scandir infodir info-file?) '()))))
+ (define (info-file-language file)
+ (let* ((base (if (string-suffix? ".gz" file)
+ (basename file ".info.gz")
+ (basename file ".info")))
+ (dot (string-rindex base #\.)))
+ (if dot
+ (string-drop base (+ 1 dot))
+ "en")))
+
(define (install-info info)
- (setenv "PATH" (string-append #+gzip "/bin")) ;for info.gz files
- (zero?
- (system* (string-append #+texinfo "/bin/install-info") "--silent"
- info (string-append #$output "/share/info/dir"))))
+ (let ((language (info-file-language info)))
+ ;; We need to choose a valid locale for $LANGUAGE to be honored.
+ (setenv "LC_ALL" "en_US.utf8")
+ (setenv "LANGUAGE" language)
+ (zero?
+ (system* #+(file-append texinfo "/bin/install-info")
+ "--silent" info
+ (apply string-append #$output "/share/info/dir"
+ (if (string=? "en" language)
+ '("")
+ `("." ,language)))))))
+
+ (setenv "PATH" (string-append #+gzip "/bin")) ;for info.gz files
+ (setenv "GUIX_LOCPATH"
+ #+(file-append glibc-utf8-locales "/lib/locale"))
(mkdir-p (string-append #$output "/share/info"))
(exit (every install-info
(gexp->derivation "info-dir" build
#:local-build? #t
- #:substitutable? #f))
+ #:substitutable? #f
+ #:properties
+ `((type . profile-hook)
+ (hook . info-dir))))
(define (ghc-package-cache-file manifest)
"Return a derivation that builds the GHC 'package.cache' file for all the
(map manifest-entry-name (manifest-entries manifest)))
(gexp->derivation "ghc-package-cache" build
#:local-build? #t
- #:substitutable? #f)
+ #:substitutable? #f
+ #:properties
+ `((type . profile-hook)
+ (hook . ghc-package-cache)))
(return #f))))
(define (ca-certificate-bundle manifest)
;; install a UTF-8 locale.
(setenv "LOCPATH"
(string-append #+glibc-utf8-locales "/lib/locale/"
- #+(package-version glibc-utf8-locales)))
+ #+(version-major+minor
+ (package-version glibc-utf8-locales))))
(setlocale LC_ALL "en_US.utf8")
(match (append-map ca-files '#$(manifest-inputs manifest))
(gexp->derivation "ca-certificate-bundle" build
#:local-build? #t
- #:substitutable? #f))
+ #:substitutable? #f
+ #:properties
+ `((type . profile-hook)
+ (hook . ca-certificate-bundle))))
+
+(define (glib-schemas manifest)
+ "Return a derivation that unions all schemas from manifest entries and
+creates the Glib 'gschemas.compiled' file."
+ (define glib ; lazy reference
+ (module-ref (resolve-interface '(gnu packages glib)) 'glib))
+
+ (mlet %store-monad ((%glib (manifest-lookup-package manifest "glib"))
+ ;; XXX: Can't use glib-compile-schemas corresponding
+ ;; to the glib referenced by 'manifest'. Because
+ ;; '%glib' can be either a package or store path, and
+ ;; there's no way to get the "bin" output for the later.
+ (glib-compile-schemas
+ -> #~(string-append #+glib:bin
+ "/bin/glib-compile-schemas")))
+
+ (define build
+ (with-imported-modules '((guix build utils)
+ (guix build union)
+ (guix build profiles)
+ (guix search-paths)
+ (guix records))
+ #~(begin
+ (use-modules (guix build utils)
+ (guix build union)
+ (guix build profiles)
+ (srfi srfi-26))
+
+ (let* ((destdir (string-append #$output "/share/glib-2.0/schemas"))
+ (schemadirs (filter file-exists?
+ (map (cut string-append <> "/share/glib-2.0/schemas")
+ '#$(manifest-inputs manifest)))))
+
+ ;; Union all the schemas.
+ (mkdir-p (string-append #$output "/share/glib-2.0"))
+ (union-build destdir schemadirs
+ #:log-port (%make-void-port "w"))
+
+ (let ((dir destdir))
+ (when (file-is-directory? dir)
+ (ensure-writable-directory dir)
+ (invoke #+glib-compile-schemas
+ (string-append "--targetdir=" dir)
+ dir)))))))
+
+ ;; Don't run the hook when there's nothing to do.
+ (if %glib
+ (gexp->derivation "glib-schemas" build
+ #:local-build? #t
+ #:substitutable? #f
+ #:properties
+ `((type . profile-hook)
+ (hook . glib-schemas)))
+ (return #f))))
(define (gtk-icon-themes manifest)
"Return a derivation that unions all icon themes from manifest entries and
(if %gtk+
(gexp->derivation "gtk-icon-themes" build
#:local-build? #t
- #:substitutable? #f)
+ #:substitutable? #f
+ #:properties
+ `((type . profile-hook)
+ (hook . gtk-icon-themes)))
(return #f))))
(define (gtk-im-modules manifest)
(if (or gtk+ gtk+-2)
(gexp->derivation "gtk-im-modules" gexp
#:local-build? #t
- #:substitutable? #f)
+ #:substitutable? #f
+ #:properties
+ `((type . profile-hook)
+ (hook . gtk-im-modules)))
(return #f)))))
(define (xdg-desktop-database manifest)
"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."
- (mlet %store-monad ((desktop-file-utils
+ (define desktop-file-utils ; lazy reference
+ (module-ref (resolve-interface '(gnu packages freedesktop))
+ 'desktop-file-utils))
+
+ (mlet %store-monad ((glib
(manifest-lookup-package
- manifest "desktop-file-utils")))
+ manifest "glib")))
(define build
(with-imported-modules '((guix build utils)
(guix build union))
#: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.
- (if desktop-file-utils
+ ;; Don't run the hook when 'glib' is not referenced.
+ (if glib
(gexp->derivation "xdg-desktop-database" build
#:local-build? #t
- #:substitutable? #f)
+ #:substitutable? #f
+ #:properties
+ `((type . profile-hook)
+ (hook . xdg-desktop-database)))
(return #f))))
(define (xdg-mime-database manifest)
(if glib
(gexp->derivation "xdg-mime-database" build
#:local-build? #t
- #:substitutable? #f)
+ #:substitutable? #f
+ #:properties
+ `((type . profile-hook)
+ (hook . xdg-mime-database)))
(return #f))))
;; Several font packages may install font files into same directory, so
(unless (and (zero? (system* mkfontscale))
(zero? (system* mkfontdir)))
(exit #f))
- (when (empty-file? fonts-scale-file)
+ (when (and (file-exists? fonts-scale-file)
+ (empty-file? fonts-scale-file))
(delete-file fonts-scale-file))
- (when (empty-file? fonts-dir-file)
+ (when (and (file-exists? fonts-dir-file)
+ (empty-file? fonts-dir-file))
(delete-file fonts-dir-file))))
directories)))))))
(guix build union)
(srfi srfi-26))
#:local-build? #t
- #:substitutable? #f))
+ #:substitutable? #f
+ #:properties
+ `((type . profile-hook)
+ (hook . fonts-dir))))
(define (manual-database manifest)
"Return a derivation that builds the manual page database (\"mandb\") for
the entries in MANIFEST."
- (define man-db ;lazy reference
- (module-ref (resolve-interface '(gnu packages man)) 'man-db))
+ (define gdbm-ffi
+ (module-ref (resolve-interface '(gnu packages guile))
+ 'guile-gdbm-ffi))
+
+ (define zlib
+ (module-ref (resolve-interface '(gnu packages compression)) 'zlib))
+
+ (define config.scm
+ (scheme-file "config.scm"
+ #~(begin
+ (define-module #$'(guix config) ;placate Geiser
+ #:export (%libz))
+
+ (define %libz
+ #+(file-append zlib "/lib/libz")))))
+
+ (define modules
+ (cons `((guix config) => ,config.scm)
+ (delete '(guix config)
+ (source-module-closure `((guix build utils)
+ (guix man-db))))))
(define build
- #~(begin
- (use-modules (guix build utils)
- (srfi srfi-1)
- (srfi srfi-19)
- (srfi srfi-26))
-
- (define entries
- (filter-map (lambda (directory)
- (let ((man (string-append directory "/share/man")))
- (and (directory-exists? man)
- man)))
- '#$(manifest-inputs manifest)))
-
- (define manpages-collection-dir
- (string-append (getenv "PWD") "/manpages-collection"))
-
- (define man-directory
- (string-append #$output "/share/man"))
-
- (define (get-manpage-tail-path manpage-path)
- (let ((index (string-contains manpage-path "/share/man/")))
- (unless index
- (error "Manual path doesn't contain \"/share/man/\":"
- manpage-path))
- (string-drop manpage-path (+ index (string-length "/share/man/")))))
-
- (define (populate-manpages-collection-dir entries)
- (let ((manpages (append-map (cut find-files <> #:stat stat) entries)))
- (for-each (lambda (manpage)
- (let* ((dest-file (string-append
- manpages-collection-dir "/"
- (get-manpage-tail-path manpage))))
- (mkdir-p (dirname dest-file))
- (catch 'system-error
- (lambda ()
- (symlink manpage dest-file))
- (lambda args
- ;; Different packages may contain the same
- ;; manpage. Simply ignore the symlink error.
- #t))))
- manpages)))
-
- (mkdir-p manpages-collection-dir)
- (populate-manpages-collection-dir entries)
-
- ;; Create a mandb config file which contains a custom made
- ;; manpath. The associated catpath is the location where the database
- ;; gets generated.
- (copy-file #+(file-append man-db "/etc/man_db.conf")
- "man_db.conf")
- (substitute* "man_db.conf"
- (("MANDB_MAP /usr/man /var/cache/man/fsstnd")
- (string-append "MANDB_MAP " manpages-collection-dir " "
- man-directory)))
-
- (mkdir-p man-directory)
- (setenv "MANPATH" (string-join entries ":"))
-
- (format #t "Creating manual page database for ~a packages... "
- (length entries))
- (force-output)
- (let* ((start-time (current-time))
- (exit-status (system* #+(file-append man-db "/bin/mandb")
- "--quiet" "--create"
- "-C" "man_db.conf"))
- (duration (time-difference (current-time) start-time)))
- (format #t "done in ~,3f s~%"
- (+ (time-second duration)
- (* (time-nanosecond duration) (expt 10 -9))))
- (force-output)
- (zero? exit-status))))
+ (with-imported-modules modules
+ (with-extensions (list gdbm-ffi) ;for (guix man-db)
+ #~(begin
+ (use-modules (guix man-db)
+ (guix build utils)
+ (srfi srfi-1)
+ (srfi srfi-19))
+
+ (define (compute-entries)
+ ;; This is the most expensive part (I/O and CPU, due to
+ ;; decompression), so report progress as we traverse INPUTS.
+ (let* ((inputs '#$(manifest-inputs manifest))
+ (total (length inputs)))
+ (append-map (lambda (directory count)
+ (format #t "\r[~3d/~3d] building list of \
+man-db entries..."
+ count total)
+ (force-output)
+ (let ((man (string-append directory
+ "/share/man")))
+ (if (directory-exists? man)
+ (mandb-entries man)
+ '())))
+ inputs
+ (iota total 1))))
+
+ (define man-directory
+ (string-append #$output "/share/man"))
+
+ (mkdir-p man-directory)
+
+ (format #t "Creating manual page database...~%")
+ (force-output)
+ (let* ((start (current-time))
+ (entries (compute-entries))
+ (_ (write-mandb-database (string-append man-directory
+ "/index.db")
+ entries))
+ (duration (time-difference (current-time) start)))
+ (newline)
+ (format #t "~a entries processed in ~,1f s~%"
+ (length entries)
+ (+ (time-second duration)
+ (* (time-nanosecond duration) (expt 10 -9))))
+ (force-output))))))
(gexp->derivation "manual-database" build
- #:modules '((guix build utils)
- (srfi srfi-19)
- (srfi srfi-26))
- #:local-build? #t))
+
+ ;; 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
+ #:properties
+ `((type . profile-hook)
+ (hook . manual-database))))
+
+(define (texlive-configuration manifest)
+ "Return a derivation that builds a TeXlive configuration for the entries in
+MANIFEST."
+ (define entry->texlive-input
+ (match-lambda
+ (($ <manifest-entry> name version output thing deps)
+ (if (string-prefix? "texlive-" name)
+ (cons (gexp-input thing output)
+ (append-map entry->texlive-input deps))
+ '()))))
+ (define build
+ (with-imported-modules '((guix build utils)
+ (guix build union))
+ #~(begin
+ (use-modules (guix build utils)
+ (guix build union))
+
+ ;; Build a modifiable union of all texlive inputs. We do this so
+ ;; that TeX live can resolve the parent and grandparent directories
+ ;; correctly. There might be a more elegant way to accomplish this.
+ (union-build #$output
+ '#$(append-map entry->texlive-input
+ (manifest-entries manifest))
+ #:create-all-directories? #t
+ #:log-port (%make-void-port "w"))
+ (let ((texmf.cnf (string-append
+ #$output
+ "/share/texmf-dist/web2c/texmf.cnf")))
+ (when (file-exists? texmf.cnf)
+ (substitute* texmf.cnf
+ (("^TEXMFROOT = .*")
+ (string-append "TEXMFROOT = " #$output "/share\n"))
+ (("^TEXMF = .*")
+ "TEXMF = $TEXMFROOT/share/texmf-dist\n"))))
+ #t)))
+
+ (with-monad %store-monad
+ (if (any (cut string-prefix? "texlive-" <>)
+ (map manifest-entry-name (manifest-entries manifest)))
+ (gexp->derivation "texlive-configuration" build
+ #:substitutable? #f
+ #:local-build? #t
+ #:properties
+ `((type . profile-hook)
+ (hook . texlive-configuration)))
+ (return #f))))
(define %default-profile-hooks
;; This is the list of derivation-returning procedures that are called by
fonts-dir-file
ghc-package-cache-file
ca-certificate-bundle
+ glib-schemas
gtk-icon-themes
gtk-im-modules
+ texlive-configuration
xdg-desktop-database
xdg-mime-database))
#:key
(hooks %default-profile-hooks)
(locales? #t)
+ (allow-collisions? #f)
+ (relative-symlinks? #f)
system target)
"Return a derivation that builds a profile (aka. 'user environment') with
the given MANIFEST. The profile includes additional derivations returned by
the monadic procedures listed in HOOKS--such as an Info 'dir' file, etc.
+Unless ALLOW-COLLISIONS? is true, a '&profile-collision-error' is raised if
+entries in MANIFEST collide (for instance if there are two same-name packages
+with a different version number.)
When LOCALES? is true, the build is performed under a UTF-8 locale; this adds
a dependency on the 'glibc-utf8-locales' package.
+When RELATIVE-SYMLINKS? is true, use relative file names for symlink targets.
+This is one of the things to do for the result to be relocatable.
+
When TARGET is true, it must be a GNU triplet, and the packages in MANIFEST
are cross-built for TARGET."
- (mlet %store-monad ((system (if system
- (return system)
- (current-system)))
- (extras (if (null? (manifest-entries manifest))
- (return '())
- (sequence %store-monad
- (map (lambda (hook)
- (hook manifest))
- hooks)))))
+ (mlet* %store-monad ((system (if system
+ (return system)
+ (current-system)))
+ (ok? (if allow-collisions?
+ (return #t)
+ (check-for-collisions manifest system
+ #:target target)))
+ (extras (if (null? (manifest-entries manifest))
+ (return '())
+ (mapm %store-monad
+ (lambda (hook)
+ (hook manifest))
+ hooks))))
(define inputs
(append (filter-map (lambda (drv)
(and (derivation? drv)
#~(begin
(setenv "LOCPATH"
#$(file-append glibc-utf8-locales "/lib/locale/"
- (package-version glibc-utf8-locales)))
+ (version-major+minor
+ (package-version glibc-utf8-locales))))
(setlocale LC_ALL "en_US.utf8")))
(define builder
(map sexp->search-path-specification
(delete-duplicates
'#$(map search-path-specification->sexp
- (append-map manifest-entry-search-paths
- (manifest-entries manifest))))))
+ (manifest-search-paths manifest)))))
(build-profile #$output '#$inputs
+ #:symlink #$(if relative-symlinks?
+ #~symlink-relative
+ #~symlink)
#:manifest '#$(manifest->gexp manifest)
#:search-paths search-paths))))
#:system system
#:target target
+ ;; Don't complain about _IO* on Guile 2.2.
+ #:env-vars '(("GUILE_WARN_DEPRECATED" . "no"))
+
;; Not worth offloading.
#:local-build? #t
;; to have no substitute to offer.
#:substitutable? #f)))
+(define* (profile-search-paths profile
+ #:optional (manifest (profile-manifest profile))
+ #:key (getenv (const #f)))
+ "Read the manifest of PROFILE and evaluate the values of search path
+environment variables required by PROFILE; return a list of
+specification/value pairs. If MANIFEST is not #f, it is assumed to be the
+manifest of PROFILE, which avoids rereading it.
+
+Use GETENV to determine the current settings and report only settings not
+already effective."
+ (evaluate-search-paths (manifest-search-paths manifest)
+ (list profile) getenv))
+
(define (profile-regexp profile)
"Return a regular expression that matches PROFILE's name and number."
(make-regexp (string-append "^" (regexp-quote (basename profile))
(compose string->number (cut match:substring <> 1)))
0))
+(define %profile-generation-rx
+ ;; Regexp that matches profile generation.
+ (make-regexp "(.*)-([0-9]+)-link$"))
+
+(define (generation-profile file)
+ "If FILE is a profile generation GC root such as \"guix-profile-42-link\",
+return its corresponding profile---e.g., \"guix-profile\". Otherwise return
+#f."
+ (match (regexp-exec %profile-generation-rx file)
+ (#f #f)
+ (m (let ((profile (match:substring m 1)))
+ (and (file-exists? (string-append profile "/manifest"))
+ profile)))))
+
(define (generation-numbers profile)
"Return the sorted list of generation numbers of PROFILE, or '(0) if no
former profiles were found."
- (define* (scandir name #:optional (select? (const #t))
- (entry<? (@ (ice-9 i18n) string-locale<?)))
- ;; XXX: Bug-fix version introduced in Guile v2.0.6-62-g139ce19.
- (define (enter? dir stat result)
- (and stat (string=? dir name)))
-
- (define (visit basename result)
- (if (select? basename)
- (cons basename result)
- result))
-
- (define (leaf name stat result)
- (and result
- (visit (basename name) result)))
-
- (define (down name stat result)
- (visit "." '()))
-
- (define (up name stat result)
- (visit ".." result))
-
- (define (skip name stat result)
- ;; All the sub-directories are skipped.
- (visit (basename name) result))
-
- (define (error name* stat errno result)
- (if (string=? name name*) ; top-level NAME is unreadable
- result
- (visit (basename name*) result)))
-
- (and=> (file-system-fold enter? leaf down up skip error #f name lstat)
- (lambda (files)
- (sort files entry<?))))
-
(match (scandir (dirname profile)
(cute regexp-exec (profile-regexp profile) <>))
(#f ; no profile directory
(profile profile)
(generation number)))))
(else
- (switch-symlinks profile generation)
+ (switch-symlinks profile (basename generation))
current))))
(define (switch-to-previous-generation profile)
(else
(delete-and-return)))))
+(define %user-profile-directory
+ (and=> (getenv "HOME")
+ (cut string-append <> "/.guix-profile")))
+
+(define %profile-directory
+ (string-append %state-directory "/profiles/"
+ (or (and=> (or (getenv "USER")
+ (getenv "LOGNAME"))
+ (cut string-append "per-user/" <>))
+ "default")))
+
+(define %current-profile
+ ;; Call it `guix-profile', not `profile', to allow Guix profiles to
+ ;; coexist with Nix profiles.
+ (string-append %profile-directory "/guix-profile"))
+
+(define (ensure-profile-directory)
+ "Attempt to create /…/profiles/per-user/$USER if needed."
+ (let ((s (stat %profile-directory #f)))
+ (unless (and s (eq? 'directory (stat:type s)))
+ (catch 'system-error
+ (lambda ()
+ (mkdir-p %profile-directory))
+ (lambda args
+ ;; Often, we cannot create %PROFILE-DIRECTORY because its
+ ;; parent directory is root-owned and we're running
+ ;; unprivileged.
+ (raise (condition
+ (&message
+ (message
+ (format #f
+ (G_ "while creating directory `~a': ~a")
+ %profile-directory
+ (strerror (system-error-errno args)))))
+ (&fix-hint
+ (hint
+ (format #f (G_ "Please create the @file{~a} directory, \
+with you as the owner.")
+ %profile-directory))))))))
+
+ ;; Bail out if it's not owned by the user.
+ (unless (or (not s) (= (stat:uid s) (getuid)))
+ (raise (condition
+ (&message
+ (message
+ (format #f (G_ "directory `~a' is not owned by you")
+ %profile-directory)))
+ (&fix-hint
+ (hint
+ (format #f (G_ "Please change the owner of @file{~a} \
+to user ~s.")
+ %profile-directory (or (getenv "USER")
+ (getenv "LOGNAME")
+ (getuid))))))))))
+
+(define (canonicalize-profile profile)
+ "If PROFILE points to a profile in %PROFILE-DIRECTORY, return that.
+Otherwise return PROFILE unchanged. The goal is to treat '-p ~/.guix-profile'
+as if '-p' was omitted." ; see <http://bugs.gnu.org/17939>
+ ;; Trim trailing slashes so 'readlink' can do its job.
+ (let ((profile (string-trim-right profile #\/)))
+ (catch 'system-error
+ (lambda ()
+ (let ((target (readlink profile)))
+ (if (string=? (dirname target) %profile-directory)
+ target
+ profile)))
+ (const profile))))
+
+(define %known-shorthand-profiles
+ ;; Known shorthand forms for profiles that the user manipulates.
+ (list (string-append (config-directory #:ensure? #f) "/current")
+ %user-profile-directory))
+
+(define (user-friendly-profile profile)
+ "Return either ~/.guix-profile or ~/.config/guix/current if that's what
+PROFILE refers to, directly or indirectly, or PROFILE."
+ (or (find (lambda (shorthand)
+ (and shorthand
+ (let ((target (false-if-exception
+ (readlink shorthand))))
+ (and target (string=? target profile)))))
+ %known-shorthand-profiles)
+ profile))
+
;;; profiles.scm ends here
HCoop / jackhill / guix / guix.git / blobdiff