aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2022-08-08 17:37:12 +0200
committerLudovic Courtès <ludo@gnu.org>2022-08-09 15:16:06 +0200
commit64a070717c3de32332201df5d6d2d52a7f99dce9 (patch)
tree3cc82ff54e077de279abc7393e9f469c41f79ece
parentcf60a0a906440ccb007bae1243c3e0397c3a0aba (diff)
downloadguix-64a070717c3de32332201df5d6d2d52a7f99dce9.tar
guix-64a070717c3de32332201df5d6d2d52a7f99dce9.tar.gz
channels: Add 'repository->guix-channel'.
* guix/channels.scm (repository->guix-channel): New procedure. * guix/scripts/describe.scm (display-checkout-info): Use it instead of the (git) interface, and adjust accordingly.
-rw-r--r--guix/channels.scm21
-rw-r--r--guix/scripts/describe.scm40
2 files changed, 35 insertions, 26 deletions
diff --git a/guix/channels.scm b/guix/channels.scm
index 689b30e0eb..a5e9d7774d 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -77,6 +77,7 @@
%default-guix-channel
%default-channels
guix-channel?
+ repository->guix-channel
channel-instance?
channel-instance-channel
@@ -202,6 +203,26 @@ introduction, add it."
(introduction %guix-channel-introduction))
chan))
+(define* (repository->guix-channel directory
+ #:key
+ (introduction %guix-channel-introduction))
+ "Look for a Git repository in DIRECTORY or its ancestors and return a
+channel that uses that repository and the commit HEAD currently points to; use
+INTRODUCTION as the channel's introduction. Return #f if no Git repository
+could be found at DIRECTORY or one of its ancestors."
+ (catch 'git-error
+ (lambda ()
+ (with-repository (repository-discover directory) repository
+ (let* ((head (repository-head repository))
+ (commit (oid->string (reference-target head))))
+ (channel
+ (inherit %default-guix-channel)
+ (url (repository-working-directory repository))
+ (commit commit)
+ (branch (reference-shorthand head))
+ (introduction introduction)))))
+ (const #f)))
+
(define-record-type <channel-instance>
(channel-instance channel commit checkout)
channel-instance?
diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm
index 7e4f682053..0c310e3da8 100644
--- a/guix/scripts/describe.scm
+++ b/guix/scripts/describe.scm
@@ -29,7 +29,6 @@
#:use-module (guix profiles)
#:autoload (guix colors) (supports-hyperlinks? hyperlink)
#:autoload (guix openpgp) (openpgp-format-fingerprint)
- #:use-module (git)
#:autoload (json builder) (scm->json-string)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
@@ -148,40 +147,29 @@ Display information about the channels currently in use.\n"))
"Display information about the current checkout according to FMT, a symbol
denoting the requested format. Exit if the current directory does not lie
within a Git checkout."
- (let* ((program (car (command-line)))
- (directory (catch 'git-error
- (lambda ()
- (repository-discover (dirname program)))
- (lambda (key err)
- (report-error (G_ "failed to determine origin~%"))
- (display-hint (format #f (G_ "Perhaps this
+ (let* ((program (car (command-line)))
+ (channel (repository->guix-channel (dirname program))))
+ (unless channel
+ (report-error (G_ "failed to determine origin~%"))
+ (display-hint (format #f (G_ "Perhaps this
@command{guix} command was not obtained with @command{guix pull}? Its version
string is ~a.~%")
- %guix-version))
- (exit 1))))
- (repository (repository-open directory))
- (head (repository-head repository))
- (commit (oid->string (reference-target head))))
+ %guix-version))
+ (exit 1))
+
(match fmt
('human
(format #t (G_ "Git checkout:~%"))
- (format #t (G_ " repository: ~a~%") (dirname directory))
- (format #t (G_ " branch: ~a~%") (reference-shorthand head))
- (format #t (G_ " commit: ~a~%") commit))
+ (format #t (G_ " repository: ~a~%") (channel-url channel))
+ (format #t (G_ " branch: ~a~%") (channel-branch channel))
+ (format #t (G_ " commit: ~a~%") (channel-commit channel)))
('channels
- (pretty-print `(list ,(channel->code (channel (name 'guix)
- (url (dirname directory))
- (commit commit))))))
+ (pretty-print `(list ,(channel->code channel))))
('json
- (display (channel->json (channel (name 'guix)
- (url (dirname directory))
- (commit commit))))
+ (display (channel->json channel))
(newline))
('recutils
- (channel->recutils (channel (name 'guix)
- (url (dirname directory))
- (commit commit))
- (current-output-port))))
+ (channel->recutils channel (current-output-port))))
(display-package-search-path fmt)))
(define* (display-profile-info profile fmt