aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2013-05-16 20:04:13 +0200
committerLudovic Courtès <ludo@gnu.org>2013-05-16 20:04:13 +0200
commit70c4329172020bf6cc81170c379ef8d0bd0a9ba0 (patch)
tree7d3101453794daede43885f44499474c940e341d
parent101d9f3fd43b436d5dc7ef13e644c7fbbc7f62d5 (diff)
downloadguix-70c4329172020bf6cc81170c379ef8d0bd0a9ba0.tar
guix-70c4329172020bf6cc81170c379ef8d0bd0a9ba0.tar.gz
package: Make sure the profile directory is owned by the user.
* guix/scripts/package.scm (guix-package)[ensure-default-profile]: Check the owner of %PROFILE-DIRECTORY. Report an error when the owner is not the current user. Add `rtfm' procedure. * doc/guix.texi (Invoking guix package): Mention the ownership test.
-rw-r--r--doc/guix.texi3
-rw-r--r--guix/scripts/package.scm54
2 files changed, 38 insertions, 19 deletions
diff --git a/doc/guix.texi b/doc/guix.texi
index c0f8f0fc82..54325a5b16 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -490,7 +490,8 @@ directory is normally
@var{localstatedir} is the value passed to @code{configure} as
@code{--localstatedir}, and @var{user} is the user name. It must be
created by @code{root}, with @var{user} as the owner. When it does not
-exist, @command{guix package} emits an error about it.
+exist, or is not owned by @var{user}, @command{guix package} emits an
+error about it.
The @var{options} can be among the following:
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index aeeeab307c..7fda71e7e9 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -600,7 +600,14 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
(#f #f)))
(define (ensure-default-profile)
- ;; Ensure the default profile symlink and directory exist.
+ ;; Ensure the default profile symlink and directory exist and are
+ ;; writable.
+
+ (define (rtfm)
+ (format (current-error-port)
+ (_ "Try \"info '(guix) Invoking guix package'\" for \
+more information.~%"))
+ (exit 1))
;; Create ~/.guix-profile if it doesn't exist yet.
(when (and %user-environment-directory
@@ -609,23 +616,34 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
(lstat %user-environment-directory))))
(symlink %current-profile %user-environment-directory))
- ;; Attempt to create /…/profiles/per-user/$USER if needed.
- (unless (directory-exists? %profile-directory)
- (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.
- (format (current-error-port)
- (_ "error: while creating directory `~a': ~a~%")
- %profile-directory
- (strerror (system-error-errno args)))
- (format (current-error-port)
- (_ "Please create the `~a' directory, with you as the owner.~%")
- %profile-directory)
- (exit 1)))))
+ (let ((s (stat %profile-directory #f)))
+ ;; Attempt to create /…/profiles/per-user/$USER if needed.
+ (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.
+ (format (current-error-port)
+ (_ "error: while creating directory `~a': ~a~%")
+ %profile-directory
+ (strerror (system-error-errno args)))
+ (format (current-error-port)
+ (_ "Please create the `~a' directory, with you as the owner.~%")
+ %profile-directory)
+ (rtfm))))
+
+ ;; Bail out if it's not owned by the user.
+ (unless (= (stat:uid s) (getuid))
+ (format (current-error-port)
+ (_ "error: directory `~a' is not owned by you~%")
+ %profile-directory)
+ (format (current-error-port)
+ (_ "Please change the owner of `~a' to user ~s.~%")
+ %profile-directory (or (getenv "USER") (getuid)))
+ (rtfm))))
(define (process-actions opts)
;; Process any install/remove/upgrade action from OPTS.