From 9505b54a4f9f0265c9d8be53763f0c59d6f62a44 Mon Sep 17 00:00:00 2001 From: zimoun Date: Tue, 19 Jan 2021 22:28:08 +0100 Subject: utils: Add string distance. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/utils.scm (string-distance): New procedure. (string-closest): New procedure. * tests/utils.scm ("string-distance", "string-closest"): New tests. Signed-off-by: Ludovic Courtès --- guix/utils.scm | 47 ++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 46 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/utils.scm b/guix/utils.scm index a85e2f495c..1625cab19b 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -8,6 +8,7 @@ ;;; Copyright © 2017 Mathieu Othacehe ;;; Copyright © 2018, 2020 Marius Bakke ;;; Copyright © 2020 Efraim Flashner +;;; Copyright © 2021 Simon Tournier ;;; ;;; This file is part of GNU Guix. ;;; @@ -37,6 +38,7 @@ #:use-module (guix memoization) #:use-module ((guix build utils) #:select (dump-port mkdir-p delete-file-recursively)) #:use-module ((guix build syscalls) #:select (mkdtemp! fdatasync)) + #:use-module ((guix combinators) #:select (fold2)) #:use-module (guix diagnostics) ;, &error-location, etc. #:use-module (ice-9 format) #:use-module (ice-9 regex) @@ -115,7 +117,10 @@ call-with-decompressed-port compressed-output-port call-with-compressed-output-port - canonical-newline-port)) + canonical-newline-port + + string-distance + string-closest)) ;;; @@ -880,6 +885,46 @@ be determined." ;; raising an error would upset Geiser users #f)))))) + +;;; +;;; String comparison. +;;; + +(define (string-distance s1 s2) + "Compute the Levenshtein distance between two strings." + ;; Naive implemenation + (define loop + (mlambda (as bt) + (match as + (() (length bt)) + ((a s ...) + (match bt + (() (length as)) + ((b t ...) + (if (char=? a b) + (loop s t) + (1+ (min + (loop as t) + (loop s bt) + (loop s t)))))))))) + + (let ((c1 (string->list s1)) + (c2 (string->list s2))) + (loop c1 c2))) + +(define* (string-closest trial tests #:key (threshold 3)) + "Return the string from TESTS that is the closest from the TRIAL, +according to 'string-distance'. If the TESTS are too far from TRIAL, +according to THRESHOLD, then #f is returned." + (identity ;discard second return value + (fold2 (lambda (test closest minimal) + (let ((dist (string-distance trial test))) + (if (and (< dist minimal) (< dist threshold)) + (values test dist) + (values closest minimal)))) + #f +inf.0 + tests))) + ;;; Local Variables: ;;; eval: (put 'call-with-progress-reporter 'scheme-indent-function 1) ;;; End: -- cgit v1.2.3 From 0df4d5aa04b53e8a6842045deb323b785db5b20a Mon Sep 17 00:00:00 2001 From: zimoun Date: Tue, 19 Jan 2021 22:28:09 +0100 Subject: guix: scripts: Add hint for option typo. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/scripts.scm (option-hint): New procedure. (parse-command-line): Add 'option-hint'. Co-authored-by: Ludovic Courtès --- guix/scripts.scm | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts.scm b/guix/scripts.scm index 34cba35401..c9ea9f2e29 100644 --- a/guix/scripts.scm +++ b/guix/scripts.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2015, 2016 Alex Kost ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen ;;; Copyright © 2021 Ricardo Wurmus +;;; Copyright © 2021 Simon Tournier ;;; ;;; This file is part of GNU Guix. ;;; @@ -112,6 +113,13 @@ procedure, but both the category and synopsis are meant to be read (parsed) by doc body ...))))) +(define (option-hint guess options) + "Return the closest long-name OPTIONS from GUESS, +according to'string-distance'." + (define (options->long-names options) + (filter string? (append-map option-names options))) + (string-closest guess (options->long-names options) #:threshold 3)) + (define (args-fold* args options unrecognized-option-proc operand-proc . seeds) "A wrapper on top of `args-fold' that does proper user-facing error reporting." @@ -149,7 +157,12 @@ parameter of 'args-fold'." ;; Actual parsing takes place here. (apply args-fold* args options (lambda (opt name arg . rest) - (leave (G_ "~A: unrecognized option~%") name)) + (let ((hint (option-hint name options))) + (report-error (G_ "~A: unrecognized option~%") name) + (when hint + (display-hint + (format #f (G_ "Did you mean @code{~a}?~%") hint))) + (exit 1))) argument-handler seeds)) -- cgit v1.2.3 From f0a1a55c66c9ad0e5af504907d9558e9d91f30eb Mon Sep 17 00:00:00 2001 From: zimoun Date: Tue, 19 Jan 2021 22:28:10 +0100 Subject: ui: Add hint for command typo. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/ui.scm (command-hint): New variable (run-guix-command): Use it. Signed-off-by: Ludovic Courtès --- guix/ui.scm | 18 +++++++++++++++--- 1 file changed, 15 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 45ae14f83c..9cea405456 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -2123,6 +2123,14 @@ Run COMMAND with ARGS.\n")) (define (run-guix-command command . args) "Run COMMAND with the given ARGS. Report an error when COMMAND is not found." + (define (command-hint guess commands) + (define command-names + (map (lambda (command) + (match (command-name command) + ((head tail ...) head))) + commands)) + (string-closest (symbol->string guess) command-names #:threshold 3)) + (define module ;; Check if there is a matching extension. (match (search-path (extension-directories) @@ -2132,9 +2140,13 @@ found." (lambda () (resolve-interface `(guix scripts ,command))) (lambda _ - (format (current-error-port) - (G_ "guix: ~a: command not found~%") command) - (show-guix-usage)))) + (let ((hint (command-hint command (commands)))) + (format (current-error-port) + (G_ "guix: ~a: command not found~%") command) + (when hint + (display-hint (format #f (G_ "Did you mean @code{~a}?") + hint))) + (show-guix-usage))))) (file (load file) (resolve-interface `(guix extensions ,command))))) -- cgit v1.2.3 From 814ee99da89a0bcc6cf53d61763d345ed95e067c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 3 Feb 2021 14:43:29 +0100 Subject: store: 'store-path-hash-part' really returns false for invalid file names. The "store-path-hash-part #f", due to a SRFI-64 bug, was marked as successful even though 'store-path-hash-part' was throwing an exception. * guix/store.scm (store-path-hash-part): Really return #f. --- guix/store.scm | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index e0b15abce3..81bb9eb847 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -2173,10 +2173,12 @@ valid inputs." (define (store-path-hash-part path) "Return the hash part of PATH as a base32 string, or #f if PATH is not a syntactically valid store path." - (let* ((base (store-path-base path)) - (hash (string-take base 32))) - (and (string-every %nix-base32-charset hash) - hash))) + (match (store-path-base path) + (#f #f) + (base + (let ((hash (string-take base 32))) + (and (string-every %nix-base32-charset hash) + hash))))) (define (derivation-log-file drv) "Return the build log file for DRV, a derivation file name, or #f if it -- cgit v1.2.3 From 316fc2acbb112bfa572ae30f95a93bcd56621234 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 27 Jan 2021 14:46:10 +0100 Subject: channels: Record 'guix' channel metadata in (guix config). Partially fixes . * 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. --- build-aux/build-self.scm | 11 ++++++-- guix/channels.scm | 30 ++++++++++++-------- guix/config.scm.in | 11 +++++++- guix/describe.scm | 28 +++++++++++++++++-- guix/scripts/describe.scm | 70 +++++++++++++++++++++++------------------------ guix/self.scm | 25 +++++++++++++---- 6 files changed, 116 insertions(+), 59 deletions(-) (limited to 'guix') 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 +;;; Copyright © 2014, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès ;;; ;;; 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 +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019, 2021 Ludovic Courtès ;;; Copyright © 2017 Caleb Ristvedt ;;; ;;; 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 -- cgit v1.2.3 From 55daad123e896c0e83361496cf49625289ee3571 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 27 Jan 2021 22:23:19 +0100 Subject: build: Add '--with-channel-commit' and related configure flags. Partially fixes . * m4/guix.m4 (GUIX_CHANNEL_METADATA): New macro. * configure.ac: Use it. * guix/config.scm.in (%channel-metadata): Adjust accordingly. --- configure.ac | 1 + guix/config.scm.in | 20 +++++++++++++++++--- m4/guix.m4 | 30 +++++++++++++++++++++++++++++- 3 files changed, 47 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/configure.ac b/configure.ac index aa97f67ebe..aa60471143 100644 --- a/configure.ac +++ b/configure.ac @@ -25,6 +25,7 @@ AM_GNU_GETTEXT_VERSION([0.18.1]) GUIX_SYSTEM_TYPE GUIX_ASSERT_SUPPORTED_SYSTEM +GUIX_CHANNEL_METADATA AM_CONDITIONAL([CROSS_COMPILING], [test "x$cross_compiling" = "xyes"]) diff --git a/guix/config.scm.in b/guix/config.scm.in index 223c9eb418..d582d91d74 100644 --- a/guix/config.scm.in +++ b/guix/config.scm.in @@ -61,9 +61,23 @@ (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) + (let ((url @GUIX_CHANNEL_URL@) + (commit @GUIX_CHANNEL_COMMIT@) + (intro @GUIX_CHANNEL_INTRODUCTION@)) + (and url commit + `(repository + (version 0) + (url ,url) + (branch "master") ;XXX: doesn't really matter + (commit ,commit) + (name guix) + ,@(if intro + `((introduction + (channel-introduction + (version 0) + (commit ,(car intro)) + (signer ,(cdr intro))))) + '()))))) (define %storedir "@storedir@") diff --git a/m4/guix.m4 b/m4/guix.m4 index f8eb5aaf51..c1ce0876fa 100644 --- a/m4/guix.m4 +++ b/m4/guix.m4 @@ -1,5 +1,5 @@ dnl GNU Guix --- Functional package management for GNU -dnl Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019, 2020 Ludovic Courtès +dnl Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019, 2020, 2021 Ludovic Courtès dnl Copyright © 2014 Mark H Weaver dnl Copyright © 2017 Efraim Flashner dnl @@ -398,3 +398,31 @@ that of the existing installation '$guix_cv_current_localstatedir']) esac fi fi]) + +dnl GUIX_CHANNEL_METADATA +dnl +dnl Provide the channel metadata for this build. This allows 'guix describe' +dnl to return meaningful data, as it would for a 'guix pull'-provided 'guix'. +dnl The default URL and introduction are taken from (guix channels). +AC_DEFUN([GUIX_CHANNEL_METADATA], [ + AC_ARG_WITH([channel-url], [AS_HELP_STRING([--with-channel-url=URL], + [assert that this is built from the Git repository at URL])], + [guix_channel_url="\"$withval\""], + [guix_channel_url="\"https://git.savannah.gnu.org/git/guix.git\""]) + AC_ARG_WITH([channel-commit], [AS_HELP_STRING([--with-channel-commit=COMMIT], + [assert that this is built from COMMIT])], + [guix_channel_commit="\"$withval\""], + [guix_channel_commit="#f"]) + AC_ARG_WITH([channel-introduction], [AS_HELP_STRING([--with-channel-introduction=COMMIT:FINGERPRINT], + [specify COMMIT and FINGERPRINT as the introduction of this channel])], + [guix_channel_introduction="'(\"`echo $withval | cut -f1 -d:`\" \"`echo $withval | cut -f2 -d:`\")"], + [guix_channel_introduction="'(\"9edb3f66fd807b096b48283debdcddccfea34bad\" . \"BBB0 2DDF 2CEA F6A8 0D1D E643 A2A0 6DF2 A33A 54FA\")"]) + + GUIX_CHANNEL_URL="$guix_channel_url" + GUIX_CHANNEL_COMMIT="$guix_channel_commit" + GUIX_CHANNEL_INTRODUCTION="$guix_channel_introduction" + + AC_SUBST([GUIX_CHANNEL_URL]) + AC_SUBST([GUIX_CHANNEL_COMMIT]) + AC_SUBST([GUIX_CHANNEL_INTRODUCTION]) +]) -- cgit v1.2.3 From 29009fdb2d3636eafa77b406da2430b08a22d47e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 2 Feb 2021 09:37:33 +0100 Subject: channels: Consider the current channel commit as authentic. Fixes . When the ~/.cache/guix/authentication is empty, this change allows authentication to start at the current commit, as shown by 'guix describe', instead of starting from the introductory commit, which would take more and more time (there's currently 18K commits per year). * guix/git-authenticate.scm (authenticate-repository): Add #:authentic-commits. [authenticated-commits]: Append it. * guix/channels.scm (authenticate-channel)[authentic-commits]: New variable. Pass it to 'authenticate-repository'. --- guix/channels.scm | 14 ++++++++++++++ guix/git-authenticate.scm | 9 ++++++--- 2 files changed, 20 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/channels.scm b/guix/channels.scm index 3cc3b4c438..05226e766b 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -47,6 +47,7 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:autoload (guix describe) (current-channels) ;XXX: circular dep #:autoload (guix self) (whole-package make-config.scm) #:autoload (guix inferior) (gexp->derivation-in-inferior) ;FIXME: circular dep #:autoload (guix quirks) (%quirks %patches applicable-patch? apply-patch) @@ -344,6 +345,18 @@ commits)...~%") (progress-reporter/bar (length commits))) + (define authentic-commits + ;; Consider the currently-used commit of CHANNEL as authentic so + ;; authentication can skip it and all its closure. + (match (find (lambda (candidate) + (eq? (channel-name candidate) (channel-name channel))) + (current-channels)) + (#f '()) + (channel + (if (channel-commit channel) + (list (channel-commit channel)) + '())))) + ;; XXX: Too bad we need to re-open CHECKOUT. (with-repository checkout repository (authenticate-repository repository @@ -354,6 +367,7 @@ commits)...~%") #:keyring-reference (string-append keyring-reference-prefix keyring-reference) + #:authentic-commits authentic-commits #:make-reporter make-reporter #:cache-key cache-key))) diff --git a/guix/git-authenticate.scm b/guix/git-authenticate.scm index 4ab5419bd6..ab3fcd8b2f 100644 --- a/guix/git-authenticate.scm +++ b/guix/git-authenticate.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019, 2020 Ludovic Courtès +;;; Copyright © 2019, 2020, 2021 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -376,12 +376,14 @@ instead of '~a'") (cache-key (repository-cache-key repository)) (end (reference-target (repository-head repository))) + (authentic-commits '()) (historical-authorizations '()) (make-reporter (const progress-reporter/silent))) "Authenticate REPOSITORY up to commit END, an OID. Authentication starts with commit START, an OID, which must be signed by SIGNER; an exception is -raised if that is not the case. Return an alist mapping OpenPGP public keys +raised if that is not the case. Commits listed in AUTHENTIC-COMMITS and their +closure are considered authentic. Return an alist mapping OpenPGP public keys to the number of commits signed by that key that have been traversed. The OpenPGP keyring is loaded from KEYRING-REFERENCE in REPOSITORY, where @@ -404,7 +406,8 @@ denoting the authorized keys for commits whose parent lack the (filter-map (lambda (id) (false-if-git-not-found (commit-lookup repository (string->oid id)))) - (previously-authenticated-commits cache-key))) + (append (previously-authenticated-commits cache-key) + authentic-commits))) (define commits ;; Commits to authenticate, excluding the closure of -- cgit v1.2.3 From fada92bb807aabd514ad20b86ad3a35a7ccbc9e7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 5 Feb 2021 22:56:53 +0100 Subject: guix describe: 'display-profile-content' checks the right generation. Fixes a regression introduced in 316fc2acbb112bfa572ae30f95a93bcd56621234, whereby 'guix pull -l' would always display channel information corresponding to the latest profile generation. Reported by Vagrant Cascadian. * guix/scripts/describe.scm (profile-generation-channels): New procedure. (display-profile-content): Change default value of 'channels'. --- guix/scripts/describe.scm | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm index cd5d3838a8..6f8d9aceec 100644 --- a/guix/scripts/describe.scm +++ b/guix/scripts/describe.scm @@ -211,9 +211,17 @@ what matters." channels)))) (display-package-search-path fmt)) +(define (profile-generation-channels profile number) + "Return the list of channels for generation NUMBER of PROFILE." + (profile-channels (if (zero? number) + profile + (generation-file-name profile number)))) + (define* (display-profile-content profile number #:optional - (channels (profile-channels profile))) + (channels + (profile-generation-channels profile + number))) "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 " -- cgit v1.2.3 From e1bdab4f0f7fe28a07054ea09b0c6153ddd05a24 Mon Sep 17 00:00:00 2001 From: Leo Prikler Date: Sun, 24 Jan 2021 11:47:15 +0100 Subject: build-system: Add renpy-build-system. * guix/build/renpy-build-system.scm: New file. * guix/build-system/renpy.scm: New file. * Makefile.am (MODULES): Add them here. * doc/guix.texi (Build Systems): Document renpy-build-system. --- Makefile.am | 2 + doc/guix.texi | 13 ++++ guix/build-system/renpy.scm | 131 ++++++++++++++++++++++++++++++++++++++ guix/build/renpy-build-system.scm | 99 ++++++++++++++++++++++++++++ 4 files changed, 245 insertions(+) create mode 100644 guix/build-system/renpy.scm create mode 100644 guix/build/renpy-build-system.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 407df1556c..798808bde6 100644 --- a/Makefile.am +++ b/Makefile.am @@ -150,6 +150,7 @@ MODULES = \ guix/build-system/node.scm \ guix/build-system/perl.scm \ guix/build-system/python.scm \ + guix/build-system/renpy.scm \ guix/build-system/ocaml.scm \ guix/build-system/qt.scm \ guix/build-system/waf.scm \ @@ -205,6 +206,7 @@ MODULES = \ guix/build/ocaml-build-system.scm \ guix/build/qt-build-system.scm \ guix/build/r-build-system.scm \ + guix/build/renpy-build-system.scm \ guix/build/rakudo-build-system.scm \ guix/build/ruby-build-system.scm \ guix/build/scons-build-system.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index e0f6921a90..7d18703283 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -7880,6 +7880,19 @@ passes flags specified by the @code{#:make-maker-flags} or Which Perl package is used can be specified with @code{#:perl}. @end defvr +@defvr {Scheme Variable} renpy-build-system +This variable is exported by @code{(guix build-system renpy)}. It implements +the more or less standard build procedure used by Ren'py games, which consists +of loading @code{#:game} once, thereby creating bytecode for it. + +It further creates a wrapper script in @code{bin/} and a desktop entry in +@code{share/applications}, both of which can be used to launch the game. + +Which Ren'py package is used can be specified with @code{#:renpy}. +Games can also be installed in outputs other than ``out'' by using +@code{#:output}. +@end defvr + @defvr {Scheme Variable} qt-build-system This variable is exported by @code{(guix build-system qt)}. It is intended for use with applications using Qt or KDE. diff --git a/guix/build-system/renpy.scm b/guix/build-system/renpy.scm new file mode 100644 index 0000000000..35edc0056d --- /dev/null +++ b/guix/build-system/renpy.scm @@ -0,0 +1,131 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021 Leo Prikler +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix build-system renpy) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix memoization) + #:use-module (guix packages) + #:use-module (guix derivations) + #:use-module (guix search-paths) + #:use-module (guix build-system) + #:use-module (guix build-system gnu) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (%renpy-build-system-modules + default-renpy + renpy-build + renpy-build-system)) + +(define (default-renpy) + "Return the default Ren'py package." + ;; Lazily resolve the binding to avoid a circular dependency. + (let ((module (resolve-interface '(gnu packages game-development)))) + (module-ref module 'renpy))) + +(define %renpy-build-system-modules + ;; Build-side modules imported by default. + `((guix build renpy-build-system) + (guix build json) + (guix build python-build-system) + ,@%gnu-build-system-modules)) + +(define* (lower name + #:key source inputs native-inputs outputs system target + (renpy (default-renpy)) + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME." + (define private-keywords + '(#:source #:target #:renpy #:inputs #:native-inputs)) + + (and (not target) ;XXX: no cross-compilation + (bag + (name name) + (system system) + (host-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@inputs + + ;; Keep the standard inputs of 'gnu-build-system'. + ,@(standard-packages))) + (build-inputs `(("renpy" ,renpy) + ,@native-inputs)) + (outputs outputs) + (build renpy-build) + (arguments (strip-keyword-arguments private-keywords arguments))))) + +(define* (renpy-build store name inputs + #:key + (phases '(@ (guix build renpy-build-system) + %standard-phases)) + (configure-flags ''()) + (outputs '("out")) + (output "out") + (game "game") + (search-paths '()) + (system (%current-system)) + (guile #f) + (imported-modules %renpy-build-system-modules) + (modules '((guix build renpy-build-system) + (guix build utils)))) + "Build SOURCE using RENPY, and with INPUTS." + (define builder + `(begin + (use-modules ,@modules) + (renpy-build #:name ,name + #:source ,(match (assoc-ref inputs "source") + (((? derivation? source)) + (derivation->output-path source)) + ((source) + source) + (source + source)) + #:configure-flags ,configure-flags + #:system ,system + #:phases ,phases + #:outputs %outputs + #:output ,output + #:game ,game + #:search-paths ',(map search-path-specification->sexp + search-paths) + #:inputs %build-inputs))) + + (define guile-for-build + (match guile + ((? package?) + (package-derivation store guile system #:graft? #f)) + (#f ; the default + (let* ((distro (resolve-interface '(gnu packages commencement))) + (guile (module-ref distro 'guile-final))) + (package-derivation store guile system #:graft? #f))))) + + (build-expression->derivation store name builder + #:inputs inputs + #:system system + #:modules imported-modules + #:outputs outputs + #:guile-for-build guile-for-build)) + +(define renpy-build-system + (build-system + (name 'renpy) + (description "The Ren'py build system") + (lower lower))) diff --git a/guix/build/renpy-build-system.scm b/guix/build/renpy-build-system.scm new file mode 100644 index 0000000000..464fc97b13 --- /dev/null +++ b/guix/build/renpy-build-system.scm @@ -0,0 +1,99 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021 Leo Prikler +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix build renpy-build-system) + #:use-module ((guix build gnu-build-system) #:prefix gnu:) + #:use-module ((guix build python-build-system) #:prefix python:) + #:use-module (guix build json) + #:use-module (guix build utils) + #:use-module (ice-9 match) + #:use-module (ice-9 ftw) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (%standard-phases + renpy-build)) + +(define* (build #:key game #:allow-other-keys) + (for-each make-file-writable + (find-files game (lambda (pred stat) + (eq? (stat:type stat) 'directory)))) + (invoke "renpy" + "--json-dump" (string-append game "/renpy-build.json") + game + ;; should be "compile", but renpy wants to compile itself really + ;; badly if we do + "quit") + #t) + +(define* (install #:key outputs game (output "out") #:allow-other-keys) + (let* ((out (assoc-ref outputs output)) + (json-dump (call-with-input-file (string-append game + "/renpy-build.json") + read-json)) + (build (assoc-ref json-dump "build")) + (executable-name (assoc-ref build "executable_name")) + (directory-name (assoc-ref build "directory_name"))) + (let ((launcher (string-append out "/bin/" executable-name)) + (data (string-append out "/share/renpy/" directory-name))) + (mkdir-p (string-append out "/bin")) + (copy-recursively game data) + ;; We don't actually want the metadata to be dumped in the output + ;; directory + (delete-file (string-append data "/renpy-build.json")) + (call-with-output-file launcher + (lambda (port) + (format port "#!~a~%~a ~a \"$@\"" + (which "bash") + (which "renpy") + data))) + (chmod launcher #o755))) + #t) + +(define* (install-desktop-file #:key outputs game (output "out") + #:allow-other-keys) + (let* ((out (assoc-ref outputs output)) + (json-dump (call-with-input-file (string-append game + "/renpy-build.json") + read-json)) + (build (assoc-ref json-dump "build")) + (directory-name (assoc-ref build "directory_name")) + (executable-name (assoc-ref build "executable_name"))) + (make-desktop-entry-file + (string-append out "/share/applications/" executable-name ".desktop") + #:name (assoc-ref json-dump "name") + #:generic-name (assoc-ref build "display_name") + #:exec (string-append (which "renpy") " " + out "/share/renpy/" directory-name) + #:categories '("Game" "Visual Novel"))) + #t) + +(define %standard-phases + (modify-phases gnu:%standard-phases + (add-after 'unpack 'enable-bytecode-determinism + (assoc-ref python:%standard-phases 'enable-bytecode-determinism)) + (delete 'bootstrap) + (delete 'configure) + (replace 'build build) + (delete 'check) + (replace 'install install) + (add-after 'install 'install-desktop-file install-desktop-file))) + +(define* (renpy-build #:key inputs (phases %standard-phases) + #:allow-other-keys #:rest args) + "Build the given Ren'py package, applying all of PHASES in order." + (apply gnu:gnu-build #:inputs inputs #:phases phases args)) -- cgit v1.2.3 From 18a4882e3029a084d2f0c63d9d0148682a854546 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 8 Feb 2021 22:23:09 +0100 Subject: docker: Pass '--hard-dereference' to 'tar' to ensure reproducible builds. Reported by zimoun at . * guix/docker.scm (%tar-determinism-options): Add '--hard-dereference'. Co-authored-by: zimoun --- guix/docker.scm | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/docker.scm b/guix/docker.scm index 97ac6d982b..889aaeacb5 100644 --- a/guix/docker.scm +++ b/guix/docker.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Ricardo Wurmus -;;; Copyright © 2017, 2018, 2019 Ludovic Courtès +;;; Copyright © 2017, 2018, 2019, 2021 Ludovic Courtès ;;; Copyright © 2018 Chris Marusich ;;; ;;; This file is part of GNU Guix. @@ -113,7 +113,14 @@ Return a version of TAG that follows these rules." (define %tar-determinism-options ;; GNU tar options to produce archives deterministically. '("--sort=name" "--mtime=@1" - "--owner=root:0" "--group=root:0")) + "--owner=root:0" "--group=root:0" + + ;; When 'build-docker-image' is passed store items, the 'nlink' of the + ;; files therein leads tar to store hard links instead of actual copies. + ;; However, the 'nlink' count depends on deduplication in the store; it's + ;; an "implicit input" to the build process. '--hard-dereference' + ;; eliminates it. + "--hard-dereference")) (define directive-file ;; Return the file or directory created by a 'evaluate-populate-directive' -- cgit v1.2.3 From a643deac2de81755a1843a3b41dd53857678bebc Mon Sep 17 00:00:00 2001 From: Lars-Dominik Braun Date: Thu, 4 Feb 2021 10:43:45 +0100 Subject: environment: Allow starting from existing profile. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/scripts/environment.scm (%options): Add -p/--profile switch. (show-help): Document new switch. (guix-environment): Handle new 'profile switch. Signed-off-by: 宋文武 --- guix/scripts/environment.scm | 22 ++++++++++++++++++++-- 1 file changed, 20 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index f4d12f89bf..a39347743e 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -21,6 +21,7 @@ (define-module (guix scripts environment) #:use-module (guix ui) #:use-module (guix store) + #:use-module (guix utils) #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module (guix grafts) #:use-module (guix derivations) @@ -136,6 +137,8 @@ COMMAND or an interactive shell in that environment.\n")) FILE evaluates to")) (display (G_ " -m, --manifest=FILE create environment with the manifest from FILE")) + (display (G_ " + -p, --profile=PATH create environment from profile at PATH")) (display (G_ " --ad-hoc include all specified packages in the environment instead of only their inputs")) @@ -269,6 +272,10 @@ use '--preserve' instead~%")) (option '(#\P "link-profile") #f #f (lambda (opt name arg result) (alist-cons 'link-profile? #t result))) + (option '(#\p "profile") #t #f + (lambda (opt name arg result) + (alist-cons 'profile arg + (alist-delete 'profile result eq?)))) (option '(#\u "user") #t #f (lambda (opt name arg result) (alist-cons 'user arg @@ -706,6 +713,7 @@ message if any test fails." (user (assoc-ref opts 'user)) (bootstrap? (assoc-ref opts 'bootstrap?)) (system (assoc-ref opts 'system)) + (profile (assoc-ref opts 'profile)) (command (or (assoc-ref opts 'exec) ;; Spawn a shell if the user didn't specify ;; anything in particular. @@ -735,8 +743,16 @@ message if any test fails." #:dry-run? (assoc-ref opts 'dry-run?)) (with-status-verbosity (assoc-ref opts 'verbosity) - (define manifest + (define manifest-from-opts (options/resolve-packages store opts)) + (when (and profile + (> (length (manifest-entries manifest-from-opts)) 0)) + (leave (G_ "'--profile' cannot be used with package options~%"))) + + (define manifest + (if profile + (profile-manifest profile) + manifest-from-opts)) (set-build-options-from-command-line store opts) @@ -755,7 +771,9 @@ message if any test fails." system)) (prof-drv (manifest->derivation manifest system bootstrap?)) - (profile -> (derivation->output-path prof-drv)) + (profile -> (if profile + (readlink* profile) + (derivation->output-path prof-drv))) (gc-root -> (assoc-ref opts 'gc-root))) ;; First build the inputs. This is necessary even for -- cgit v1.2.3