From efcb4441f1c2dd6729938ca68f2fdfd6243e24e4 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sun, 13 May 2018 16:08:24 +0200
Subject: profiles: Add '%current-profile', 'user-friendly-profile', & co.

* guix/scripts/package.scm (%user-profile-directory)
(%profile-directory, %current-profile, canonicalize-profile)
(user-friendly-profile): Move to...
* guix/profiles.scm: ... here.
---
 guix/profiles.scm | 49 ++++++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 48 insertions(+), 1 deletion(-)

(limited to 'guix/profiles.scm')

diff --git a/guix/profiles.scm b/guix/profiles.scm
index 9bddf88162..95a8f30335 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -25,6 +25,7 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (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))
@@ -118,7 +119,13 @@
             generation-file-name
             switch-to-generation
             roll-back
-            delete-generation))
+            delete-generation
+
+            %user-profile-directory
+            %profile-directory
+            %current-profile
+            canonicalize-profile
+            user-friendly-profile))
 
 ;;; Commentary:
 ;;;
@@ -1515,4 +1522,44 @@ 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 (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
+'-p' was omitted."                           ; see <http://bugs.gnu.org/17939>
+
+  ;; Trim trailing slashes so that the basename comparison below works as
+  ;; intended.
+  (let ((profile (string-trim-right profile #\/)))
+    (if (and %user-profile-directory
+             (string=? (canonicalize-path (dirname profile))
+                       (dirname %user-profile-directory))
+             (string=? (basename profile) (basename %user-profile-directory)))
+        %current-profile
+        profile)))
+
+(define (user-friendly-profile profile)
+  "Return either ~/.guix-profile if that's what PROFILE refers to, directly or
+indirectly, or PROFILE."
+  (if (and %user-profile-directory
+           (false-if-exception
+            (string=? (readlink %user-profile-directory) profile)))
+      %user-profile-directory
+      profile))
+
 ;;; profiles.scm ends here
-- 
cgit v1.2.3