me
/
guix
Archived
1
0
Fork 0
Code

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 2021-01-27 14:46:10 +01:00
parent 814ee99da8
commit 316fc2acbb
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
6 changed files with 116 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
build-aux/build-self.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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. ;;; This file is part of GNU Guix.
;;; ;;;
@ -241,7 +241,7 @@ interface (FFI) of Guile.")
(define* (build-program source version (define* (build-program source version
#:optional (guile-version (effective-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." "Return a program that computes the derivation to build Guix from SOURCE."
(define select? (define select?
;; Select every module but (guix config) and non-Guix modules. ;; Select every module but (guix config) and non-Guix modules.
@ -359,6 +359,8 @@ interface (FFI) of Guile.")
(run-with-store store (run-with-store store
(guix-derivation source version (guix-derivation source version
#$guile-version #$guile-version
#:channel-metadata
'#$channel-metadata
#:pull-version #:pull-version
#$pull-version) #$pull-version)
#:system system) #:system system)
@ -380,7 +382,9 @@ interface (FFI) of Guile.")
;; The procedure below is our return value. ;; The procedure below is our return value.
(define* (build source (define* (build source
#:key verbose? (version (date-version-string)) system #:key verbose?
(version (date-version-string)) channel-metadata
system
(pull-version 0) (pull-version 0)
;; For the standalone Guix, default to Guile 3.0. For old ;; 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 ;; Build the build program and then use it as a trampoline to build from
;; SOURCE. ;; SOURCE.
(mlet %store-monad ((build (build-program source version guile-version (mlet %store-monad ((build (build-program source version guile-version
#:channel-metadata channel-metadata
#:pull-version pull-version)) #:pull-version pull-version))
(system (if system (return system) (current-system))) (system (if system (return system) (current-system)))
(home -> (getenv "HOME")) (home -> (getenv "HOME"))

30
guix/channels.scm
View File

@ -626,16 +626,23 @@ that unconditionally resumes the continuation."
(values (run-with-store store mvalue) (values (run-with-store store mvalue)
store)))) store))))
(define* (build-from-source name source (define* (build-from-source instance
#:key core verbose? commit #:key core verbose? (dependencies '()))
(dependencies '())) "Return a derivation to build Guix from INSTANCE, using the self-build
"Return a derivation to build Guix from SOURCE, using the self-build script script contained therein. When CORE is true, build package modules under
contained therein; use COMMIT as the version string. When CORE is true, build SOURCE using CORE, an instance of Guix."
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 ;; 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 ;; 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 ;; right dependencies, build procedure, etc., which the Guix-in-use may not
;; be know. ;; know.
(define script (define script
(string-append source "/" %self-build-file)) (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 ;; cause us to redo half of the BUILD computation several times just
;; to realize it gives the same result. ;; to realize it gives the same result.
(with-trivial-build-handler (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)))) #:pull-version %pull-version))))
;; Build a set of modules that extend Guix using the standard method. ;; 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 "Return, as a monadic value, the derivation for INSTANCE, a channel
instance. DEPENDENCIES is a list of extensions providing Guile modules that instance. DEPENDENCIES is a list of extensions providing Guile modules that
INSTANCE depends on." INSTANCE depends on."
(build-from-source (symbol->string (build-from-source instance
(channel-name (channel-instance-channel instance)))
(channel-instance-checkout instance)
#:commit (channel-instance-commit instance)
#:core core #:core core
#:dependencies dependencies)) #:dependencies dependencies))

11
guix/config.scm.in
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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> ;;; Copyright © 2017 Caleb Ristvedt <caleb.ristvedt@cune.org>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
@ -23,6 +23,8 @@
%guix-bug-report-address %guix-bug-report-address
%guix-home-page-url %guix-home-page-url
%channel-metadata
%storedir %storedir
%localstatedir %localstatedir
%sysconfdir %sysconfdir
@ -56,6 +58,13 @@
(define %guix-home-page-url (define %guix-home-page-url
"@PACKAGE_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 (define %storedir
"@storedir@") "@storedir@")

28
guix/describe.scm
View File

@ -23,12 +23,13 @@
#:use-module ((guix utils) #:select (location-file)) #:use-module ((guix utils) #:select (location-file))
#:use-module ((guix store) #:select (%store-prefix store-path?)) #:use-module ((guix store) #:select (%store-prefix store-path?))
#:use-module ((guix config) #:select (%state-directory)) #: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 (srfi srfi-1)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:export (current-profile #:export (current-profile
current-profile-date current-profile-date
current-profile-entries current-profile-entries
current-channels
package-path-entries package-path-entries
package-provenance 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))))) (string-append (dirname file) "/" target)))))
(const #f))))))) (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 (define current-profile-entries
(mlambda () (mlambda ()
"Return the list of entries in the 'guix pull' profile the calling process "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) (match (current-profile)
(#f '()) (#f '())
(profile (profile
@ -105,6 +115,20 @@ lives in, or #f if this is not applicable."
(string=? (manifest-entry-name entry) "guix")) (string=? (manifest-entry-name entry) "guix"))
(current-profile-entries)))) (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) (define (package-path-entries)
"Return two values: the list of package path entries to be added to the "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 package search path, and the list to be added to %LOAD-COMPILED-PATH. These

70
guix/scripts/describe.scm
View File

@ -182,20 +182,18 @@ string is ~a.~%")
(current-output-port)))) (current-output-port))))
(display-package-search-path fmt))) (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), "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 (define number
(generation-number profile)) (and profile (generation-number profile)))
(define channels
(profile-channels (if (zero? number)
profile
(generation-file-name profile number))))
(match fmt (match fmt
('human ('human
(display-profile-content profile number)) (display-profile-content profile number channels))
('channels ('channels
(pretty-print `(list ,@(map channel->code channels)))) (pretty-print `(list ,@(map channel->code channels))))
('channels-sans-intro ('channels-sans-intro
@ -213,33 +211,29 @@ in the format specified by FMT."
channels)))) channels))))
(display-package-search-path fmt)) (display-package-search-path fmt))
(define (display-profile-content profile number) (define* (display-profile-content profile number
"Display the packages in PROFILE, generation NUMBER, in a human-readable #:optional
way and displaying details about the channel's source code." (channels (profile-channels profile)))
(display-generation profile number) "Display CHANNELS along with PROFILE info, generation NUMBER, in a
(for-each (lambda (entry) human-readable way and displaying details about the channel's source code.
(format #t " ~a ~a~%" PROFILE and NUMBER "
(manifest-entry-name entry) (when (and number profile)
(manifest-entry-version entry)) (display-generation profile number))
(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. (for-each (lambda (channel)
(reverse (format #t " ~a ~a~%"
(manifest-entries (channel-name channel)
(profile-manifest (if (zero? number) (string-take (channel-commit channel) 7))
profile (format #t (G_ " repository URL: ~a~%")
(generation-file-name profile number))))))) (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 (define %vcs-web-views
;; Hard-coded list of host names and corresponding web view URL templates. ;; 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 (with-error-handling
(match profile (match profile
(#f (#f
(display-checkout-info format)) (match (current-channels)
(()
(display-checkout-info format))
(channels
(display-profile-info #f format channels))))
(profile (profile
(display-profile-info (canonicalize-profile profile) format)))))) (display-profile-info (canonicalize-profile profile) format))))))

25
guix/self.scm
View File

@ -793,7 +793,9 @@ itself."
(((labels packages _ ...) ...) (((labels packages _ ...) ...)
(cons package 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) (pull-version 1)
(name (string-append "guix-" version)) (name (string-append "guix-" version))
(guile-version (effective-version)) (guile-version (effective-version))
@ -977,6 +979,8 @@ itself."
%guix-package-name %guix-package-name
#:package-version #:package-version
version version
#:channel-metadata
channel-metadata
#:bug-report-address #:bug-report-address
%guix-bug-report-address %guix-bug-report-address
#:home-page-url #:home-page-url
@ -1070,6 +1074,7 @@ itself."
(define* (make-config.scm #:key gzip xz bzip2 (define* (make-config.scm #:key gzip xz bzip2
(package-name "GNU Guix") (package-name "GNU Guix")
(package-version "0") (package-version "0")
(channel-metadata #f)
(bug-report-address "bug-guix@gnu.org") (bug-report-address "bug-guix@gnu.org")
(home-page-url "https://guix.gnu.org")) (home-page-url "https://guix.gnu.org"))
@ -1083,6 +1088,7 @@ itself."
%guix-version %guix-version
%guix-bug-report-address %guix-bug-report-address
%guix-home-page-url %guix-home-page-url
%channel-metadata
%system %system
%store-directory %store-directory
%state-directory %state-directory
@ -1125,6 +1131,11 @@ itself."
(define %guix-bug-report-address #$bug-report-address) (define %guix-bug-report-address #$bug-report-address)
(define %guix-home-page-url #$home-page-url) (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 (define %gzip
#+(and gzip (file-append gzip "/bin/gzip"))) #+(and gzip (file-append gzip "/bin/gzip")))
(define %bzip2 (define %bzip2
@ -1249,11 +1260,14 @@ containing MODULE-FILES and possibly other files as well."
(define* (guix-derivation source version (define* (guix-derivation source version
#:optional (guile-version (effective-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 "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 for GUILE-VERSION. Use VERSION as the version string. Use CHANNEL-METADATA
the version of the 'guix pull' protocol. Return #f if this PULL-VERSION value as the channel metadata sexp to include in (guix config).
is not supported."
PULL-VERSION specifies the version of the 'guix pull' protocol. Return #f if
this PULL-VERSION value is not supported."
(define (shorten version) (define (shorten version)
(if (and (string-every char-set:hex-digit version) (if (and (string-every char-set:hex-digit version)
(> (string-length version) 9)) (> (string-length version) 9))
@ -1278,6 +1292,7 @@ is not supported."
(set-guile-for-build guile) (set-guile-for-build guile)
(let ((guix (compiled-guix source (let ((guix (compiled-guix source
#:version version #:version version
#:channel-metadata channel-metadata
#:name (string-append "guix-" #:name (string-append "guix-"
(shorten version)) (shorten version))
#:pull-version pull-version #:pull-version pull-version