Toggle diff (382 lines)
diff --git a/build-aux/build-self.scm b/build-aux/build-self.scm
index d5bc5fb46e..6a3b9c83d4 100644
--- a/build-aux/build-self.scm
+++ b/build-aux/build-self.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -241,7 +241,7 @@ interface (FFI) of Guile.")
(define* (build-program source version
#:optional (guile-version (effective-version))
- #:key (pull-version 0))
+ #:key (pull-version 0) (channel-metadata #f))
"Return a program that computes the derivation to build Guix from SOURCE."
(define select?
;; Select every module but (guix config) and non-Guix modules.
@@ -359,6 +359,8 @@ interface (FFI) of Guile.")
(run-with-store store
(guix-derivation source version
#$guile-version
+ #:channel-metadata
+ '#$channel-metadata
#:pull-version
#$pull-version)
#:system system)
@@ -380,7 +382,9 @@ interface (FFI) of Guile.")
;; The procedure below is our return value.
(define* (build source
- #:key verbose? (version (date-version-string)) system
+ #:key verbose?
+ (version (date-version-string)) channel-metadata
+ system
(pull-version 0)
;; For the standalone Guix, default to Guile 3.0. For old
@@ -397,6 +401,7 @@ files."
;; Build the build program and then use it as a trampoline to build from
;; SOURCE.
(mlet %store-monad ((build (build-program source version guile-version
+ #:channel-metadata channel-metadata
#:pull-version pull-version))
(system (if system (return system) (current-system)))
(home -> (getenv "HOME"))
diff --git a/guix/channels.scm b/guix/channels.scm
index e7e1eb6fd0..3cc3b4c438 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -626,16 +626,23 @@ that unconditionally resumes the continuation."
(values (run-with-store store mvalue)
store))))
-(define* (build-from-source name source
- #:key core verbose? commit
- (dependencies '()))
- "Return a derivation to build Guix from SOURCE, using the self-build script
-contained therein; use COMMIT as the version string. When CORE is true, build
-package modules under SOURCE using CORE, an instance of Guix."
+(define* (build-from-source instance
+ #:key core verbose? (dependencies '()))
+ "Return a derivation to build Guix from INSTANCE, using the self-build
+script contained therein. When CORE is true, build package modules under
+SOURCE using CORE, an instance of Guix."
+ (define name
+ (symbol->string
+ (channel-name (channel-instance-channel instance))))
+ (define source
+ (channel-instance-checkout instance))
+ (define commit
+ (channel-instance-commit instance))
+
;; Running the self-build script makes it easier to update the build
;; procedure: the self-build script of the Guix-to-be-installed contains the
;; right dependencies, build procedure, etc., which the Guix-in-use may not
- ;; be know.
+ ;; know.
(define script
(string-append source "/" %self-build-file))
@@ -661,7 +668,9 @@ package modules under SOURCE using CORE, an instance of Guix."
;; cause us to redo half of the BUILD computation several times just
;; to realize it gives the same result.
(with-trivial-build-handler
- (build source #:verbose? verbose? #:version commit
+ (build source
+ #:verbose? verbose? #:version commit
+ #:channel-metadata (channel-instance->sexp instance)
#:pull-version %pull-version))))
;; Build a set of modules that extend Guix using the standard method.
@@ -672,10 +681,7 @@ package modules under SOURCE using CORE, an instance of Guix."
"Return, as a monadic value, the derivation for INSTANCE, a channel
instance. DEPENDENCIES is a list of extensions providing Guile modules that
INSTANCE depends on."
- (build-from-source (symbol->string
- (channel-name (channel-instance-channel instance)))
- (channel-instance-checkout instance)
- #:commit (channel-instance-commit instance)
+ (build-from-source instance
#:core core
#:dependencies dependencies))
diff --git a/guix/config.scm.in b/guix/config.scm.in
index b2901735d8..223c9eb418 100644
--- a/guix/config.scm.in
+++ b/guix/config.scm.in
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Caleb Ristvedt <caleb.ristvedt@cune.org>
;;;
;;; This file is part of GNU Guix.
@@ -23,6 +23,8 @@
%guix-bug-report-address
%guix-home-page-url
+ %channel-metadata
+
%storedir
%localstatedir
%sysconfdir
@@ -56,6 +58,13 @@
(define %guix-home-page-url
"@PACKAGE_URL@")
+(define %channel-metadata
+ ;; When true, this is an sexp containing metadata for the 'guix' channel
+ ;; this file was built from. This is used by (guix describe).
+
+ ;; TODO: Implement 'configure.ac' machinery to initialize it.
+ #f)
+
(define %storedir
"@storedir@")
diff --git a/guix/describe.scm b/guix/describe.scm
index ac89fc0d7c..6a31c707f0 100644
--- a/guix/describe.scm
+++ b/guix/describe.scm
@@ -23,12 +23,13 @@
#:use-module ((guix utils) #:select (location-file))
#:use-module ((guix store) #:select (%store-prefix store-path?))
#:use-module ((guix config) #:select (%state-directory))
- #:autoload (guix channels) (sexp->channel)
+ #:autoload (guix channels) (sexp->channel manifest-entry-channel)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
#:export (current-profile
current-profile-date
current-profile-entries
+ current-channels
package-path-entries
package-provenance
@@ -87,10 +88,19 @@ as a number of seconds since the Epoch, or #f if it could not be determined."
(string-append (dirname file) "/" target)))))
(const #f)))))))
+(define (channel-metadata)
+ "Return the 'guix' channel metadata sexp from (guix config) if available;
+otherwise return #f."
+ ;; Older 'build-self.scm' would create a (guix config) file without the
+ ;; '%channel-metadata' variable. Thus, properly deal with a lack of
+ ;; information.
+ (let ((module (resolve-interface '(guix config))))
+ (and=> (module-variable module '%channel-metadata) variable-ref)))
+
(define current-profile-entries
(mlambda ()
"Return the list of entries in the 'guix pull' profile the calling process
-lives in, or #f if this is not applicable."
+lives in, or the empty list if this is not applicable."
(match (current-profile)
(#f '())
(profile
@@ -105,6 +115,20 @@ lives in, or #f if this is not applicable."
(string=? (manifest-entry-name entry) "guix"))
(current-profile-entries))))
+(define current-channels
+ (mlambda ()
+ "Return the list of channels currently available, including the 'guix'
+channel. Return the empty list if this information is missing."
+ (match (current-profile-entries)
+ (()
+ ;; As a fallback, if we're not running from a profile, use 'guix'
+ ;; channel metadata from (guix config).
+ (match (channel-metadata)
+ (#f '())
+ (sexp (or (and=> (sexp->channel sexp 'guix) list) '()))))
+ (entries
+ (filter-map manifest-entry-channel entries)))))
+
(define (package-path-entries)
"Return two values: the list of package path entries to be added to the
package search path, and the list to be added to %LOAD-COMPILED-PATH. These
diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm
index e47d207ee0..cd5d3838a8 100644
--- a/guix/scripts/describe.scm
+++ b/guix/scripts/describe.scm
@@ -182,20 +182,18 @@ string is ~a.~%")
(current-output-port))))
(display-package-search-path fmt)))
-(define (display-profile-info profile fmt)
+(define* (display-profile-info profile fmt
+ #:optional
+ (channels (profile-channels profile)))
"Display information about PROFILE, a profile as created by (guix channels),
-in the format specified by FMT."
+in the format specified by FMT. PROFILE can be #f, in which case CHANNELS is
+what matters."
(define number
- (generation-number profile))
-
- (define channels
- (profile-channels (if (zero? number)
- profile
- (generation-file-name profile number))))
+ (and profile (generation-number profile)))
(match fmt
('human
- (display-profile-content profile number))
+ (display-profile-content profile number channels))
('channels
(pretty-print `(list ,@(map channel->code channels))))
('channels-sans-intro
@@ -213,33 +211,29 @@ in the format specified by FMT."
channels))))
(display-package-search-path fmt))
-(define (display-profile-content profile number)
- "Display the packages in PROFILE, generation NUMBER, in a human-readable
-way and displaying details about the channel's source code."
- (display-generation profile number)
- (for-each (lambda (entry)
+(define* (display-profile-content profile number
+ #:optional
+ (channels (profile-channels profile)))
+ "Display CHANNELS along with PROFILE info, generation NUMBER, in a
+human-readable way and displaying details about the channel's source code.
+PROFILE and NUMBER "
+ (when (and number profile)
+ (display-generation profile number))
+
+ (for-each (lambda (channel)
(format #t " ~a ~a~%"
- (manifest-entry-name entry)
- (manifest-entry-version entry))
- (match (manifest-entry-channel entry)
- ((? channel? channel)
- (format #t (G_ " repository URL: ~a~%")
- (channel-url channel))
- (when (channel-branch channel)
- (format #t (G_ " branch: ~a~%")
- (channel-branch channel)))
- (format #t (G_ " commit: ~a~%")
- (if (supports-hyperlinks?)
- (channel-commit-hyperlink channel)
- (channel-commit channel))))
- (_ #f)))
-
- ;; Show most recently installed packages last.
- (reverse
- (manifest-entries
- (profile-manifest (if (zero? number)
- profile
- (generation-file-name profile number)))))))
+ (channel-name channel)
+ (string-take (channel-commit channel) 7))
+ (format #t (G_ " repository URL: ~a~%")
+ (channel-url channel))
+ (when (channel-branch channel)
+ (format #t (G_ " branch: ~a~%")
+ (channel-branch channel)))
+ (format #t (G_ " commit: ~a~%")
+ (if (supports-hyperlinks?)
+ (channel-commit-hyperlink channel)
+ (channel-commit channel))))
+ channels))
(define %vcs-web-views
;; Hard-coded list of host names and corresponding web view URL templates.
@@ -295,6 +289,10 @@ text. The hyperlink links to a web view of COMMIT, when available."
(with-error-handling
(match profile
(#f
- (display-checkout-info format))
+ (match (current-channels)
+ (()
+ (display-checkout-info format))
+ (channels
+ (display-profile-info #f format channels))))
(profile
(display-profile-info (canonicalize-profile profile) format))))))
diff --git a/guix/self.scm b/guix/self.scm
index 15c8ad4eb9..35fba1152d 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -793,7 +793,9 @@ itself."
(((labels packages _ ...) ...)
(cons package packages))))
-(define* (compiled-guix source #:key (version %guix-version)
+(define* (compiled-guix source #:key
+ (version %guix-version)
+ (channel-metadata #f)
(pull-version 1)
(name (string-append "guix-" version))
(guile-version (effective-version))
@@ -977,6 +979,8 @@ itself."
%guix-package-name
#:package-version
version
+ #:channel-metadata
+ channel-metadata
#:bug-report-address
%guix-bug-report-address
#:home-page-url
@@ -1070,6 +1074,7 @@ itself."
(define* (make-config.scm #:key gzip xz bzip2
(package-name "GNU Guix")
(package-version "0")
+ (channel-metadata #f)
(bug-report-address "bug-guix@gnu.org")
(home-page-url "https://guix.gnu.org"))
@@ -1083,6 +1088,7 @@ itself."
%guix-version
%guix-bug-report-address
%guix-home-page-url
+ %channel-metadata
%system
%store-directory
%state-directory
@@ -1125,6 +1131,11 @@ itself."
(define %guix-bug-report-address #$bug-report-address)
(define %guix-home-page-url #$home-page-url)
+ (define %channel-metadata
+ ;; Metadata for the 'guix' channel in use. This
+ ;; information is used by (guix describe).
+ '#$channel-metadata)
+
(define %gzip
#+(and gzip (file-append gzip "/bin/gzip")))
(define %bzip2
@@ -1249,11 +1260,14 @@ containing MODULE-FILES and possibly other files as well."
(define* (guix-derivation source version
#:optional (guile-version (effective-version))
- #:key (pull-version 0))
+ #:key (pull-version 0)
+ channel-metadata)
"Return, as a monadic value, the derivation to build the Guix from SOURCE
-for GUILE-VERSION. Use VERSION as the version string. PULL-VERSION specifies
-the version of the 'guix pull' protocol. Return #f if this PULL-VERSION value
-is not supported."
+for GUILE-VERSION. Use VERSION as the version string. Use CHANNEL-METADATA
+as the channel metadata sexp to include in (guix config).
+
+PULL-VERSION specifies the version of the 'guix pull' protocol. Return #f if
+this PULL-VERSION value is not supported."
(define (shorten version)
(if (and (string-every char-set:hex-digit version)
(> (string-length version) 9))
@@ -1278,6 +1292,7 @@ is not supported."
(set-guile-for-build guile)
(let ((guix (compiled-guix source
#:version version
+ #:channel-metadata channel-metadata
#:name (string-append "guix-"
(shorten version))
#:pull-version pull-version
--
2.30.0
