02/08: describe: Try harder to find the ‘guix pull’ profile.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit c90a4e8dcd6ac650392ffcc039273baf145aa3cc
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Tue Mar 19 12:56:49 2024 +0100

    describe: Try harder to find the ‘guix pull’ profile.
    
    Fixes <https://issues.guix.gnu.org/66705>.
    
    The strategy used by ‘current-profile’ so far would fail to find the
    right profile (the one created by ‘guix pull’ or ‘guix time-machine’) in
    cases where said profile is itself included in another profile.  This
    happens, for instance, when running ‘guix shell -CW -- guix describe’,
    which, as a result, would display nothing but the ‘guix’ channel.
    
    This patch fixes that by having ‘current-profile’ not just check for the
    presence of a ‘manifest’ file but also parse it to determine whether
    it’s a ‘guix pull’ kind of manifest.
    
    * guix/describe.scm (find-profile): New procedure.
    (current-profile): Adjust to use it.
    
    Change-Id: I9194f54ce1496a6591e247c76203f497f28c330b
---
 guix/describe.scm | 48 +++++++++++++++++++++++++++++++++++++++---------
 1 file changed, 39 insertions(+), 9 deletions(-)

diff --git a/guix/describe.scm b/guix/describe.scm
index 65cd79094b..a4ca2462f4 100644
--- a/guix/describe.scm
+++ b/guix/describe.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018-2021, 2024 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -27,6 +27,7 @@
                                 sexp->channel
                                 manifest-entry-channel)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-34)
   #:use-module (ice-9 match)
   #:export (current-profile
             current-profile-date
@@ -55,20 +56,49 @@
   ;; later on.
   (program-arguments))
 
+(define (find-profile program)
+  "Return the profile created by 'guix pull' or 'guix time-machine' that
+PROGRAM lives in; PROGRAM is expected to end in \"/bin/guix\".  Return #f if
+such a profile could not be found."
+  (and (string-suffix? "/bin/guix" program)
+       ;; Note: We want to do _lexical dot-dot resolution_.  Using ".."  for
+       ;; real would instead take us into the /gnu/store directory that
+       ;; ~/.config/guix/current/bin points to, whereas we want to obtain
+       ;; ~/.config/guix/current.
+       (let ((candidate (dirname (dirname program))))
+         (and (file-exists? (string-append candidate "/manifest"))
+              (let ((manifest (guard (c ((profile-error? c) #f))
+                                (profile-manifest candidate))))
+                (define (fallback)
+                  (or (and=> (false-if-exception (readlink program))
+                             find-profile)
+                      (and=> (false-if-exception (readlink (dirname program)))
+                             (lambda (target)
+                               (find-profile (in-vicinity target "guix"))))))
+
+                ;; Is CANDIDATE the "right" profile--the one created by 'guix
+                ;; pull'?  It might be that CANDIDATE itself contains a
+                ;; symlink to the "right" profile; this happens for instance
+                ;; when using 'guix shell -CW'.  Thus, if CANDIDATE doesn't
+                ;; fit the bill, dereference PROGRAM or its parent directory
+                ;; and try again.
+                (match (and manifest
+                            (manifest-lookup manifest
+                                             (manifest-pattern (name "guix"))))
+                  (#f
+                   (fallback))
+                  (entry
+                   (if (assq 'source (manifest-entry-properties entry))
+                       candidate
+                       (fallback)))))))))
+
 (define current-profile
   (mlambda ()
     "Return the profile (created by 'guix pull') the calling process lives in,
 or #f if this is not applicable."
     (match initial-program-arguments
       ((program . _)
-       (and (string-suffix? "/bin/guix" program)
-            ;; Note: We want to do _lexical dot-dot resolution_.  Using ".."
-            ;; for real would instead take us into the /gnu/store directory
-            ;; that ~/.config/guix/current/bin points to, whereas we want to
-            ;; obtain ~/.config/guix/current.
-            (let ((candidate (dirname (dirname program))))
-              (and (file-exists? (string-append candidate "/manifest"))
-                   candidate)))))))
+       (find-profile program)))))
 
 (define (current-profile-date)
   "Return the creation date of the current profile (produced by 'guix pull'),