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.
---
 guix/scripts/package.scm | 54 ++++++++++++++++++++++++++++++++----------------
 1 file changed, 36 insertions(+), 18 deletions(-)

(limited to 'guix')

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 @@ (define (upgradeable? name current-version current-path)
       (#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 @@ (define (ensure-default-profile)
                      (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 v1.2.3