me/guix
Archived
1
0
Fork 0
Code Activity

git: Add ‘repository-info’ and use it in (guix channels).

Browse source 
* guix/git.scm (repository-info): New procedure.
* guix/channels.scm (repository->guix-channel): Use it instead of local
code.

Change-Id: I74c758c73a22e16031571ca4271cc9cab0492f6e
This commit is contained in:
Ludovic Courtès 2024-03-31 23:16:30 +02:00
parent 3cadb61963
commit a57518484e
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 26 additions and 13 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

20
guix/channels.scm
View file

@ -24,6 +24,7 @@
#:autoload (guix git) (update-cached-checkout #:autoload (guix git) (update-cached-checkout
url+commit->name url+commit->name
commit-difference commit-difference
repository-info
with-repository) with-repository)
#:autoload (guix git-authenticate) (authenticate-repository) #:autoload (guix git-authenticate) (authenticate-repository)
#:autoload (guix openpgp) (openpgp-public-key-fingerprint #:autoload (guix openpgp) (openpgp-public-key-fingerprint
@ -207,18 +208,13 @@ introduction, add it."
channel that uses that repository and the commit HEAD currently points to; use 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 INTRODUCTION as the channel's introduction. Return #f if no Git repository
could be found at DIRECTORY or one of its ancestors." could be found at DIRECTORY or one of its ancestors."
(catch 'git-error (let ((directory commit branch (repository-info directory)))
(lambda () (channel
(with-repository (repository-discover directory) repository (inherit %default-guix-channel)
(let* ((head (repository-head repository)) (url directory)
(commit (oid->string (reference-target head)))) (commit commit)
(channel (branch branch)
(inherit %default-guix-channel) (introduction introduction))))
(url (repository-working-directory repository))
(commit commit)
(branch (reference-shorthand head))
(introduction introduction)))))
(const #f)))
(define-record-type <channel-instance> (define-record-type <channel-instance>
(channel-instance channel commit checkout) (channel-instance channel commit checkout)

19
guix/git.scm
View file

@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2018-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018-2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2021 Kyle Meyer <kyle@kyleam.com> ;;; Copyright © 2021 Kyle Meyer <kyle@kyleam.com>
;;; Copyright © 2021 Marius Bakke <marius@gnu.org> ;;; Copyright © 2021 Marius Bakke <marius@gnu.org>
;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be> ;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
@ -59,6 +59,7 @@
with-repository with-repository
with-git-error-handling with-git-error-handling
false-if-git-not-found false-if-git-not-found
repository-info
update-cached-checkout update-cached-checkout
url+commit->name url+commit->name
latest-repository-commit latest-repository-commit
@ -330,6 +331,22 @@ dynamic extent of EXP."
(lambda (key err) (lambda (key err)
(report-git-error err)))) (report-git-error err))))
(define (repository-info directory)
"Open the Git repository in DIRECTORY or one of its parent and return three
values: the working directory of that repository, its checked out commit ID,
and its checked out reference (such as a branch name). Return #f (three
values) if DIRECTORY does not hold a readable Git repository."
(catch 'git-error
(lambda ()
(with-repository (repository-discover directory) repository
(let* ((head (repository-head repository))
(commit (oid->string (reference-target head))))
(values (repository-working-directory repository)
commit
(reference-shorthand head)))))
(lambda _
(values #f #f #f))))
(define* (update-submodules repository (define* (update-submodules repository
#:key (log-port (current-error-port)) #:key (log-port (current-error-port))
(fetch-options #f)) (fetch-options #f))