;;; 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)
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?
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?
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:
;;;
(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
+ (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))))
+ (default (delay #f)))
+ (properties manifest-entry-properties ; list of symbol/value pairs
+ (default '())))
(define-record-type* <manifest-pattern> manifest-pattern
make-manifest-pattern
(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)
(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 #$(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 #$(map entry->gexp deps))
(search-paths #$(map search-path-specification->sexp
- search-paths))))))
+ search-paths))
+ (properties . #$properties)))))
(match manifest
(($ <manifest> (entries ...))
(dependencies deps*)
(search-paths (map sexp->search-path-specification
search-paths))
- (parent parent))))
+ (parent parent)
+ (properties (or (assoc-ref extra-stuff 'properties)
+ '())))))
entry))))
(match sexp
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
;;;
(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)
(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)
(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
(define build
(with-imported-modules modules
- #~(begin
- (add-to-load-path (string-append #$gdbm-ffi "/share/guile/site/"
- (effective-version)))
-
- (use-modules (guix man-db)
- (guix build utils)
- (srfi srfi-1)
- (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)))
-
- (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)))
- (format #t "~a entries processed in ~,1f s~%"
- (length entries)
- (+ (time-second duration)
- (* (time-nanosecond duration) (expt 10 -9))))
- (force-output)))))
+ (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
;; <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
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))
(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
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
#: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)
(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))))
;; 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."
(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