profiles: Add 'ensure-profile-directory'.

* guix/scripts/package.scm (ensure-default-profile): Move
/var/guix/profiles/per-user handling to...
* guix/profiles.scm (ensure-profile-directory): ... here.  New
procedure.
* po/guix/POTFILES.in: Add 'guix/profiles.scm'.

3 files changed, 45 insertions, 39 deletions

diff --git a/guix/profiles.scm b/guix/profiles.scm
index de3a044646..6c3b26423e 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -28,7 +28,8 @@
   #: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)
@@ -127,6 +128,7 @@
             %user-profile-directory
             %profile-directory
             %current-profile
+            ensure-profile-directory
             canonicalize-profile
             user-friendly-profile))
 
@@ -1610,6 +1612,45 @@ because the NUMBER is zero.)"
   ;; 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 is %USER-PROFILE-DIRECTORY, return %CURRENT-PROFILE.  Otherwise
 return PROFILE unchanged.  The goal is to treat '-p ~/.guix-profile' as if
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 93a77915fe..e588ff81ed 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -68,50 +68,14 @@
 
 (define (ensure-default-profile)
   "Ensure the default profile symlink and directory exist and are writable."
-
-  (define (rtfm)
-    (format (current-error-port)
-            (G_ "Try \"info '(guix) Invoking guix package'\" for \
-more information.~%"))
-    (exit 1))
+  (ensure-profile-directory)
 
   ;; Create ~/.guix-profile if it doesn't exist yet.
   (when (and %user-profile-directory
              %current-profile
              (not (false-if-exception
                    (lstat %user-profile-directory))))
-    (symlink %current-profile %user-profile-directory))
-
-  (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)
-                  (G_ "error: while creating directory `~a': ~a~%")
-                  %profile-directory
-                  (strerror (system-error-errno args)))
-          (format (current-error-port)
-                  (G_ "Please create the `~a' directory, with you as the owner.~%")
-                  %profile-directory)
-          (rtfm))))
-
-    ;; Bail out if it's not owned by the user.
-    (unless (or (not s) (= (stat:uid s) (getuid)))
-      (format (current-error-port)
-              (G_ "error: directory `~a' is not owned by you~%")
-              %profile-directory)
-      (format (current-error-port)
-              (G_ "Please change the owner of `~a' to user ~s.~%")
-              %profile-directory (or (getenv "USER")
-                                     (getenv "LOGNAME")
-                                     (getuid)))
-      (rtfm))))
+    (symlink %current-profile %user-profile-directory)))
 
 (define (delete-generations store profile generations)
   "Delete GENERATIONS from PROFILE.
diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in
index df2cf12de2..2e37a19407 100644
--- a/po/guix/POTFILES.in
+++ b/po/guix/POTFILES.in
@@ -41,4 +41,5 @@ guix/status.scm
 guix/http-client.scm
 guix/nar.scm
 guix/channels.scm
+guix/profiles.scm
 nix/nix-daemon/guix-daemon.cc