X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/6c1a317e29c45e85e3a0e050612cdefe470b100c..1502751b3220feda44e34c07c617086538ac1296:/guix/profiles.scm diff --git a/guix/profiles.scm b/guix/profiles.scm index b3732f61ed..f5c863945c 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1,13 +1,14 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2013 Nikita Karetnikov ;;; Copyright © 2014, 2016 Alex Kost ;;; Copyright © 2015 Mark H Weaver ;;; Copyright © 2015 Sou Bunnbu -;;; Copyright © 2016 Ricardo Wurmus +;;; Copyright © 2016, 2018, 2019 Ricardo Wurmus ;;; Copyright © 2016 Chris Marusich ;;; Copyright © 2017 Huang Ying ;;; Copyright © 2017 Maxim Cournoyer +;;; Copyright © 2019 Kyle Meyer ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,14 +26,17 @@ ;;; along with GNU Guix. If not, see . (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) @@ -53,13 +57,17 @@ 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? @@ -76,6 +84,7 @@ manifest-entry-dependencies manifest-entry-search-paths manifest-entry-parent + manifest-entry-properties manifest-pattern manifest-pattern? @@ -88,6 +97,7 @@ manifest-lookup manifest-installed? manifest-matching-entries + manifest-search-paths manifest-transaction manifest-transaction? @@ -106,8 +116,10 @@ ca-certificate-bundle %default-profile-hooks profile-derivation + profile-search-paths generation-number + generation-profile generation-numbers profile-generations relative-generation-spec->number @@ -117,7 +129,14 @@ 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: ;;; @@ -143,6 +162,11 @@ (entry profile-collision-error-entry) ; (conflict profile-collision-error-conflict)) ; +(define-condition-type &unmatched-pattern-error &error + unmatched-pattern-error? + (pattern unmatched-pattern-error-pattern) ; + (manifest unmatched-pattern-error-manifest)) ; + (define-condition-type &missing-generation-error &profile-error missing-generation-error? (generation missing-generation-error-generation)) @@ -167,13 +191,15 @@ (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 ; * (default '())) (search-paths manifest-entry-search-paths ; search-path-specification* (default '())) (parent manifest-entry-parent ; promise (#f | ) - (default (delay #f)))) + (default (delay #f))) + (properties manifest-entry-properties ; list of symbol/value pairs + (default '()))) (define-record-type* manifest-pattern make-manifest-pattern @@ -273,7 +299,8 @@ file name." (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 @@ -292,19 +319,39 @@ file name." (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) @@ -312,18 +359,20 @@ denoting a specific output of a package." (define (entry->gexp entry) (match 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)))) - (($ name version output (? package? package) - (deps ...) (search-paths ...)) + search-paths)) + (properties . #$properties))) + (($ 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 (($ (entries ...)) @@ -386,7 +435,9 @@ procedure is here for backward-compatibility and will eventually vanish." (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 @@ -493,19 +544,19 @@ must be a manifest-pattern." Remove MANIFEST entries that have the same name and output as ENTRIES." (define (same-entry? entry name output) (match entry - (($ entry-name _ entry-output _ ...) + (($ entry-name _ entry-output _) (and (equal? name entry-name) (equal? output entry-output))))) (make-manifest - (append entries - (fold (lambda (entry result) - (match entry - (($ name _ out _ ...) - (filter (negate (cut same-entry? <> name out)) - result)))) - (manifest-entries manifest) - entries)))) + (fold (lambda (entry result) ;XXX: quadratic + (match 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 @@ -519,16 +570,29 @@ no match.." (->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))))) ;;; @@ -670,7 +734,13 @@ if not found." (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 + ;; . + (return #f))))) (anym %store-monad entry-lookup-package (manifest-entries manifest))) @@ -682,6 +752,8 @@ 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)) @@ -699,11 +771,31 @@ MANIFEST." (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 @@ -712,7 +804,10 @@ 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 @@ -766,7 +861,10 @@ entries of MANIFEST, or #f if MANIFEST does not have any GHC packages." (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) @@ -812,7 +910,8 @@ MANIFEST. Single-file bundles are required by programs such as Git and Lynx." ;; 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)) @@ -833,7 +932,64 @@ MANIFEST. Single-file bundles are required by programs such as Git and Lynx." (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 @@ -888,7 +1044,10 @@ creates the GTK+ 'icon-theme.cache' file for each theme." (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) @@ -960,7 +1119,10 @@ for both major versions of GTK+." (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) @@ -998,7 +1160,10 @@ MIME type." (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) @@ -1037,7 +1202,10 @@ entries. It's used to query the MIME type of a given file." (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 @@ -1095,9 +1263,11 @@ files for the fonts of the @var{manifest} entries." (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))))))) @@ -1106,92 +1276,141 @@ files for the fonts of the @var{manifest} entries." (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: + ;; . + #: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 + (($ 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 @@ -1201,8 +1420,10 @@ the entries in MANIFEST." 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)) @@ -1211,6 +1432,7 @@ the entries in MANIFEST." (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 @@ -1222,6 +1444,9 @@ 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 @@ -1233,10 +1458,10 @@ are cross-built for TARGET." #: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) @@ -1254,7 +1479,8 @@ are cross-built for TARGET." #~(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 @@ -1279,10 +1505,12 @@ are cross-built for TARGET." (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)))) @@ -1290,6 +1518,9 @@ are cross-built for TARGET." #: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 @@ -1298,6 +1529,19 @@ are cross-built for TARGET." ;; 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)) @@ -1310,6 +1554,20 @@ are cross-built for TARGET." (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." @@ -1405,7 +1663,7 @@ the generation that was current before switching." (profile profile) (generation number))))) (else - (switch-symlinks profile generation) + (switch-symlinks profile (basename generation)) current)))) (define (switch-to-previous-generation profile) @@ -1457,4 +1715,89 @@ because the NUMBER is zero.)" (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 + ;; 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