diff options
| -rw-r--r-- | build-aux/build-self.scm | 11 | ||||
| -rw-r--r-- | guix/channels.scm | 30 | ||||
| -rw-r--r-- | guix/config.scm.in | 11 | ||||
| -rw-r--r-- | guix/describe.scm | 28 | ||||
| -rw-r--r-- | guix/scripts/describe.scm | 70 | ||||
| -rw-r--r-- | guix/self.scm | 25 |
6 files changed, 116 insertions, 59 deletions
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) - (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))) +(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)) - ;; Show most recently installed packages last. - (reverse - (manifest-entries - (profile-manifest (if (zero? number) - profile - (generation-file-name profile number))))))) + (for-each (lambda (channel) + (format #t " ~a ~a~%" + (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 |