;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 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.
;;;
#: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)
profile-error-profile
&profile-not-found-error
profile-not-found-error?
- &profile-collistion-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?
profile-search-paths
generation-number
+ generation-profile
generation-numbers
profile-generations
relative-generation-spec->number
%user-profile-directory
%profile-directory
%current-profile
+ ensure-profile-directory
canonicalize-profile
user-friendly-profile))
(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))
(manifest-transitive-entries manifest))))
(define* (package->manifest-entry package #:optional (output "out")
- #:key (parent (delay #f)))
+ #:key (parent (delay #f))
+ (properties '()))
"Return a manifest entry for the OUTPUT of package PACKAGE."
;; For each dependency, keep a promise pointing to its "parent" entry.
(letrec* ((deps (map (match-lambda
(dependencies (delete-duplicates deps))
(search-paths
(package-transitive-native-search-paths package))
- (parent parent))))
+ (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)
(->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,
(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)
(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
(if %glib
(gexp->derivation "glib-schemas" build
#:local-build? #t
- #:substitutable? #f)
+ #:substitutable? #f
+ #:properties
+ `((type . profile-hook)
+ (hook . glib-schemas)))
(return #f))))
(define (gtk-icon-themes manifest)
(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)
(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
(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
(define config.scm
(scheme-file "config.scm"
#~(begin
- (define-module (guix config)
+ (define-module #$'(guix config) ;placate Geiser
#:export (%libz))
(define %libz
(srfi srfi-19))
(define (compute-entries)
- (append-map (lambda (directory)
- (let ((man (string-append directory "/share/man")))
- (if (directory-exists? man)
- (mandb-entries man)
- '())))
- '#$(manifest-inputs manifest)))
+ ;; 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"))
"/index.db")
entries))
(duration (time-difference (current-time) start)))
+ (newline)
(format #t "~a entries processed in ~,1f s~%"
(length entries)
(+ (time-second duration)
;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=29654#23>.
#:env-vars `(("MALLOC_PERTURB_" . "1"))
- #:local-build? #t))
+ #: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
glib-schemas
gtk-icon-themes
gtk-im-modules
+ texlive-configuration
xdg-desktop-database
xdg-mime-database))
#:target target)))
(extras (if (null? (manifest-entries manifest))
(return '())
- (sequence %store-monad
- (map (lambda (hook)
- (hook manifest))
- hooks)))))
+ (mapm %store-monad
+ (lambda (hook)
+ (hook manifest))
+ hooks))))
(define inputs
(append (filter-map (lambda (drv)
(and (derivation? drv)
(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."
(profile profile)
(generation number)))))
(else
- (switch-symlinks profile generation)
+ (switch-symlinks profile (basename generation))
current))))
(define (switch-to-previous-generation profile)
;; coexist with Nix profiles.
(string-append %profile-directory "/guix-profile"))
-(define (canonicalize-profile profile)
- "If PROFILE is %USER-PROFILE-DIRECTORY, return %CURRENT-PROFILE. Otherwise
-return PROFILE unchanged. The goal is to treat '-p ~/.guix-profile' as if
-'-p' was omitted." ; see <http://bugs.gnu.org/17939>
+(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))))))))))
- ;; Trim trailing slashes so that the basename comparison below works as
- ;; intended.
+(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 #\/)))
- (if (and %user-profile-directory
- (string=? (canonicalize-path (dirname profile))
- (dirname %user-profile-directory))
- (string=? (basename profile) (basename %user-profile-directory)))
- %current-profile
- 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 if that's what PROFILE refers to, directly or
-indirectly, or PROFILE."
- (if (and %user-profile-directory
- (false-if-exception
- (string=? (readlink %user-profile-directory) profile)))
- %user-profile-directory
+ "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