channels: Record 'guix' channel metadata in (guix config).
Partially fixes <https://bugs.gnu.org/45896>. * guix/config.scm.in (%channel-metadata): New variable. * guix/describe.scm (channel-metadata): Use it. (current-channels): New procedure. (current-profile-entries): Clarify docstring. * guix/self.scm (compiled-guix): Add #:channel-metadata and pass it to 'make-config.scm'. (make-config.scm): Add #:channel-metadata and define '%channel-metadata' in the generated file. (guix-derivation): Add #:channel-metadata and pass it to 'compiled-guix'. * guix/channels.scm (build-from-source): Replace 'name', 'source', and 'commit' parameters with 'instance'. Pass #:channel-metadata to BUILD. (build-channel-instance): Adjust accordingly. * build-aux/build-self.scm (build-program): Add #:channel-metadata and pass it to 'guix-derivation'. (build): Add #:channel-metadata and pass it to 'build-program'. * guix/scripts/describe.scm (display-profile-info): Add optional 'channels' parameter. Pass it to 'display-profile-content'. (display-profile-content): Add optional 'channels' parameter and honor it. Iterate on CHANNELS rather than on the manifest entries of PROFILE. (guix-describe): When PROFILE is #f, call 'current-channels' and pass it to 'display-profile-info', unless it returns the empty list.master
Ludovic Courtès
parent
814ee99da8
commit
316fc2acbb
|
|
@ -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"))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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@")
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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,16 +211,19 @@ 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)
|
||||
(channel-name channel)
|
||||
(string-take (channel-commit channel) 7))
|
||||
(format #t (G_ " repository URL: ~a~%")
|
||||
(channel-url channel))
|
||||
(when (channel-branch channel)
|
||||
|
|
@ -232,14 +233,7 @@ way and displaying details about the channel's source code."
|
|||
(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)))))))
|
||||
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
|
||||
(match (current-channels)
|
||||
(()
|
||||
(display-checkout-info format))
|
||||
(channels
|
||||
(display-profile-info #f format channels))))
|
||||
(profile
|
||||
(display-profile-info (canonicalize-profile profile) format))))))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Reference in New Issue