Merge remote-tracking branch 'savannah/master' into gnome-team

Change-Id: Iec8e15b79c6fde516294c2bfcaf8ee3575b1f745

3 files changed, 44 insertions, 10 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'),
diff --git a/guix/profiles.scm b/guix/profiles.scm
index ccc96478aa..d41802422b 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013-2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013-2024 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com>
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
@@ -652,6 +652,8 @@ denoting a specific output of a package."
                  vlist-null)))
     (_
      (raise (condition
+             (&profile-error
+              (profile (and=> (source-property sexp 'filename) dirname)))
              (&message (message "unsupported manifest format")))))))
 
 (define (read-manifest port)
diff --git a/guix/scripts/git/authenticate.scm b/guix/scripts/git/authenticate.scm
index 6ff5cee682..def4879e96 100644
--- a/guix/scripts/git/authenticate.scm
+++ b/guix/scripts/git/authenticate.scm
@@ -101,6 +101,8 @@ Authenticate the given Git checkout using COMMIT/SIGNER as its introduction.\n")
   -k, --keyring=REFERENCE
                          load keyring from REFERENCE, a Git branch"))
   (display (G_ "
+      --end=COMMIT       authenticate revisions up to COMMIT"))
+  (display (G_ "
       --stats            display commit signing statistics upon completion"))
   (display (G_ "
       --cache-key=KEY    cache authenticated commits under KEY"))