From 70c4329172020bf6cc81170c379ef8d0bd0a9ba0 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Thu, 16 May 2013 20:04:13 +0200
Subject: 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.
---
 doc/guix.texi            |  3 ++-
 guix/scripts/package.scm | 54 ++++++++++++++++++++++++++++++++----------------
 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.
-- 
cgit 1.4.1