diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build-system/julia.scm | 6 | ||||
| -rw-r--r-- | guix/build/julia-build-system.scm | 58 | ||||
| -rw-r--r-- | guix/build/profiles.scm | 6 | ||||
| -rw-r--r-- | guix/channels.scm | 134 | ||||
| -rw-r--r-- | guix/ci.scm | 42 | ||||
| -rw-r--r-- | guix/describe.scm | 34 | ||||
| -rw-r--r-- | guix/gnu-maintenance.scm | 5 | ||||
| -rw-r--r-- | guix/import/gnu.scm | 16 | ||||
| -rw-r--r-- | guix/inferior.scm | 105 | ||||
| -rw-r--r-- | guix/licenses.scm | 7 | ||||
| -rw-r--r-- | guix/profiles.scm | 86 | ||||
| -rw-r--r-- | guix/scripts/describe.scm | 52 | ||||
| -rw-r--r-- | guix/scripts/import/json.scm | 10 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 118 | ||||
| -rw-r--r-- | guix/scripts/pull.scm | 101 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 3 | ||||
| -rw-r--r-- | guix/scripts/system/reconfigure.scm | 9 | ||||
| -rw-r--r-- | guix/store/database.scm | 45 | ||||
| -rw-r--r-- | guix/ui.scm | 32 | ||||
| -rw-r--r-- | guix/utils.scm | 35 |
20 files changed, 653 insertions, 251 deletions
diff --git a/guix/build-system/julia.scm b/guix/build-system/julia.scm index 488fe9bb1d..63cb7cd864 100644 --- a/guix/build-system/julia.scm +++ b/guix/build-system/julia.scm @@ -75,13 +75,14 @@ (define* (julia-build store name inputs #:key source - (tests? #f) + (tests? #t) (phases '(@ (guix build julia-build-system) %standard-phases)) (outputs '("out")) (search-paths '()) (system (%current-system)) (guile #f) + (julia-package-name #f) (imported-modules %julia-build-system-modules) (modules '((guix build julia-build-system) (guix build utils)))) @@ -103,7 +104,8 @@ #:outputs %outputs #:search-paths ',(map search-path-specification->sexp search-paths) - #:inputs %build-inputs))) + #:inputs %build-inputs + #:julia-package-name ,julia-package-name))) (define guile-for-build (match guile diff --git a/guix/build/julia-build-system.scm b/guix/build/julia-build-system.scm index e8ebcf8ba0..8f57045a8c 100644 --- a/guix/build/julia-build-system.scm +++ b/guix/build/julia-build-system.scm @@ -21,6 +21,8 @@ #:use-module ((guix build gnu-build-system) #:prefix gnu:) #:use-module (guix build utils) #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (ice-9 rdelim) #:export (%standard-phases julia-create-package-toml julia-build)) @@ -37,18 +39,34 @@ ;; subpath where we store the package content (define %package-path "/share/julia/packages/") -(define* (install #:key source inputs outputs #:allow-other-keys) +(define (project.toml->name file) + "Look for Julia package name in the TOML file FILE (usually named +Project.toml)." + (call-with-input-file file + (lambda (in) + (let loop ((line (read-line in 'concat))) + (if (eof-object? line) + #f + (let ((m (string-match "name\\s*=\\s*\"(.*)\"" line))) + (if m (match:substring m 1) + (loop (read-line in 'concat))))))))) + +(define* (install #:key source inputs outputs julia-package-name + #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) (package-dir (string-append out %package-path - (strip-store-file-name source)))) + (or + julia-package-name + (project.toml->name "Project.toml"))))) (mkdir-p package-dir) (copy-recursively (getcwd) package-dir)) #t) -(define* (precompile #:key source inputs outputs #:allow-other-keys) +(define* (precompile #:key source inputs outputs julia-package-name + #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) (builddir (string-append out "/share/julia/")) - (package (strip-store-file-name source))) + (package (or julia-package-name (project.toml->name "Project.toml")))) (mkdir-p builddir) ;; With a patch, SOURCE_DATE_EPOCH is honored (setenv "SOURCE_DATE_EPOCH" "1") @@ -69,15 +87,23 @@ (string-append "pushfirst!(DEPOT_PATH, pop!(DEPOT_PATH)); using " package))) #t) -(define* (check #:key source inputs outputs #:allow-other-keys) - (let* ((out (assoc-ref outputs "out")) - (package (strip-store-file-name source)) - (builddir (string-append out "/share/julia/"))) - ;; With a patch, SOURCE_DATE_EPOCH is honored - (setenv "SOURCE_DATE_EPOCH" "1") - (setenv "JULIA_DEPOT_PATH" builddir) - (setenv "JULIA_LOAD_PATH" (string-append builddir "packages/")) - (invoke-julia (string-append "using Pkg;Pkg.test(\"" package "\")"))) +(define* (check #:key tests? source inputs outputs julia-package-name + #:allow-other-keys) + (when tests? + (let* ((out (assoc-ref outputs "out")) + (package (or julia-package-name (project.toml->name "Project.toml"))) + (builddir (string-append out "/share/julia/"))) + ;; With a patch, SOURCE_DATE_EPOCH is honored + (setenv "SOURCE_DATE_EPOCH" "1") + (setenv "JULIA_DEPOT_PATH" builddir) + (setenv "JULIA_LOAD_PATH" + (string-append builddir "packages/" ":" + (or (getenv "JULIA_LOAD_PATH") + ""))) + (setenv "HOME" "/tmp") + (invoke "julia" + (string-append builddir "packages/" + package "/test/runtests.jl")))) #t) (define (julia-create-package-toml outputs source @@ -112,7 +138,7 @@ version = \"" version "\" (delete 'check) ; tests must be run after installation (replace 'install install) (add-after 'install 'precompile precompile) - ;; (add-after 'install 'check check) + (add-after 'install 'check check) ;; TODO: In the future we could add a "system-image-generation" phase ;; where we use PackageCompiler.jl to speed up package loading times (delete 'configure) @@ -120,9 +146,11 @@ version = \"" version "\" (delete 'patch-usr-bin-file) (delete 'build))) -(define* (julia-build #:key inputs (phases %standard-phases) +(define* (julia-build #:key inputs julia-package-name + (phases %standard-phases) #:allow-other-keys #:rest args) "Build the given Julia package, applying all of PHASES in order." (apply gnu:gnu-build #:inputs inputs #:phases phases + #:julia-package-name julia-package-name args)) diff --git a/guix/build/profiles.scm b/guix/build/profiles.scm index 67ee9b665a..b42f498a80 100644 --- a/guix/build/profiles.scm +++ b/guix/build/profiles.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -169,7 +169,9 @@ SEARCH-PATHS." (lambda (p) (display "\ ;; This file was automatically generated and is for internal use only. -;; It cannot be passed to the '--manifest' option.\n\n" +;; It cannot be passed to the '--manifest' option. +;; Run 'guix package --export-manifest' if to export a file suitable +;; for '--manifest'.\n\n" p) (pretty-print manifest p))) diff --git a/guix/channels.scm b/guix/channels.scm index 0c84eed477..e7e1eb6fd0 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; @@ -91,6 +91,9 @@ ensure-forward-channel-update profile-channels + manifest-entry-channel + sexp->channel + channel->code channel-news-entry? channel-news-entry-commit @@ -802,13 +805,36 @@ derivation." (derivation-input-derivation input)))) (derivation-inputs drv)))) +(define (channel-instance->sexp instance) + "Return an sexp representation of INSTANCE, a channel instance." + (let* ((commit (channel-instance-commit instance)) + (channel (channel-instance-channel instance)) + (intro (channel-introduction channel))) + `(repository + (version 0) + (url ,(channel-url channel)) + (branch ,(channel-branch channel)) + (commit ,commit) + (name ,(channel-name channel)) + ,@(if intro + `((introduction + (channel-introduction + (version 0) + (commit + ,(channel-introduction-first-signed-commit + intro)) + (signer + ,(openpgp-format-fingerprint + (channel-introduction-first-commit-signer + intro)))))) + '())))) + (define (channel-instances->manifest instances) "Return a profile manifest with entries for all of INSTANCES, a list of channel instances." (define (instance->entry instance drv) - (let* ((commit (channel-instance-commit instance)) - (channel (channel-instance-channel instance)) - (intro (channel-introduction channel))) + (let ((commit (channel-instance-commit instance)) + (channel (channel-instance-channel instance))) (manifest-entry (name (symbol->string (channel-name channel))) (version (string-take commit 7)) @@ -819,23 +845,7 @@ channel instances." drv) drv)) (properties - `((source (repository - (version 0) - (url ,(channel-url channel)) - (branch ,(channel-branch channel)) - (commit ,commit) - ,@(if intro - `((introduction - (channel-introduction - (version 0) - (commit - ,(channel-introduction-first-signed-commit - intro)) - (signer - ,(openpgp-format-fingerprint - (channel-introduction-first-commit-signer - intro)))))) - '())))))))) + `((source ,(channel-instance->sexp instance))))))) (mlet* %store-monad ((derivations (channel-instance-derivations instances)) (entries -> (map instance->entry instances derivations))) @@ -900,35 +910,73 @@ to 'latest-channel-instances'." validate-pull))) (channel-instances->derivation instances))) +(define* (sexp->channel sexp #:optional (name 'channel)) + "Read SEXP, a provenance sexp as created by 'channel-instance->sexp'; use +NAME as the channel name if SEXP does not specify it. Return #f if the sexp +does not have the expected structure." + (match sexp + (('repository ('version 0) + ('url url) + ('branch branch) + ('commit commit) + rest ...) + ;; Historically channel sexps did not include the channel name. It's OK + ;; for channels created by 'channel-instances->manifest' because the + ;; entry name is the channel name, but it was missing for entries created + ;; by 'manifest-entry-with-provenance'. + (channel (name (match (assq 'name rest) + (#f name) + (('name name) name))) + (url url) + (commit commit) + (introduction + (match (assq 'introduction rest) + (#f #f) + (('introduction intro) + (sexp->channel-introduction intro)))))) + + (_ #f))) + +(define (manifest-entry-channel entry) + "Return the channel ENTRY corresponds to, or #f if that information is +missing or unreadable. ENTRY must be an entry created by +'channel-instances->manifest', with the 'source' property." + (let ((name (string->symbol (manifest-entry-name entry)))) + (match (assq-ref (manifest-entry-properties entry) 'source) + ((sexp) + (sexp->channel sexp name)) + (_ + ;; No channel information for this manifest entry. + ;; XXX: Pre-0.15.0 Guix did not provide that information, + ;; but there's not much we can do in that case. + #f)))) + (define (profile-channels profile) "Return the list of channels corresponding to entries in PROFILE. If PROFILE is not a profile created by 'guix pull', return the empty list." - (filter-map (lambda (entry) - (match (assq 'source (manifest-entry-properties entry)) - (('source ('repository ('version 0) - ('url url) - ('branch branch) - ('commit commit) - rest ...)) - (channel (name (string->symbol - (manifest-entry-name entry))) - (url url) - (commit commit) - (introduction - (match (assq 'introduction rest) - (#f #f) - (('introduction intro) - (sexp->channel-introduction intro)))))) - - ;; No channel information for this manifest entry. - ;; XXX: Pre-0.15.0 Guix did not provide that information, - ;; but there's not much we can do in that case. - (_ #f))) - + (filter-map manifest-entry-channel ;; Show most recently installed packages last. (reverse (manifest-entries (profile-manifest profile))))) +(define* (channel->code channel #:key (include-introduction? #t)) + "Return code (an sexp) to build CHANNEL. When INCLUDE-INTRODUCTION? is +true, include its introduction, if any." + (let ((intro (and include-introduction? + (channel-introduction channel)))) + `(channel + (name ',(channel-name channel)) + (url ,(channel-url channel)) + (commit ,(channel-commit channel)) + ,@(if intro + `((introduction (make-channel-introduction + ,(channel-introduction-first-signed-commit intro) + (openpgp-fingerprint + ,(openpgp-format-fingerprint + (channel-introduction-first-commit-signer + intro)))))) + '())))) + ;;; ;;; News. diff --git a/guix/ci.scm b/guix/ci.scm index f429bf198f..f04109112c 100644 --- a/guix/ci.scm +++ b/guix/ci.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2020 Mathieu Othacehe <othacehe@gnu.org> ;;; ;;; This file is part of GNU Guix. @@ -19,9 +19,13 @@ (define-module (guix ci) #:use-module (guix http-client) + #:use-module (guix utils) #:use-module (json) #:use-module (srfi srfi-1) #:use-module (ice-9 match) + #:use-module (guix i18n) + #:use-module (guix diagnostics) + #:autoload (guix channels) (channel) #:export (build-product? build-product-id build-product-type @@ -52,7 +56,9 @@ latest-builds evaluation latest-evaluations - evaluations-for-commit)) + evaluations-for-commit + + channel-with-substitutes-available)) ;;; Commentary: ;;; @@ -165,3 +171,35 @@ as one of their inputs." (string=? (checkout-commit checkout) commit)) (evaluation-checkouts evaluation))) (latest-evaluations url limit))) + +(define (find-latest-commit-with-substitutes url) + "Return the latest commit with available substitutes for the Guix package +definitions at URL. Return false if no commit were found." + (let* ((job-name (string-append "guix." (%current-system))) + (build (match (latest-builds url 1 + #:job job-name + #:status 0) ;success + ((build) build) + (_ #f))) + (evaluation (and build + (evaluation url (build-evaluation build)))) + (commit (and evaluation + (match (evaluation-checkouts evaluation) + ((checkout) + (checkout-commit checkout)))))) + commit)) + +(define (channel-with-substitutes-available chan url) + "Return a channel inheriting from CHAN but which commit field is set to the +latest commit with available substitutes for the Guix package definitions at +URL. The current system is taken into account. + +If no commit with available substitutes were found, the commit field is set to +false and a warning message is printed." + (let ((commit (find-latest-commit-with-substitutes url))) + (unless commit + (warning (G_ "could not find available substitutes at ~a~%") + url)) + (channel + (inherit chan) + (commit commit)))) diff --git a/guix/describe.scm b/guix/describe.scm index 05bf99eb58..ac89fc0d7c 100644 --- a/guix/describe.scm +++ b/guix/describe.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,6 +23,7 @@ #: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) #:use-module (srfi srfi-1) #:use-module (ice-9 match) #:export (current-profile @@ -31,7 +32,8 @@ package-path-entries package-provenance - manifest-entry-with-provenance)) + manifest-entry-with-provenance + manifest-entry-provenance)) ;;; Commentary: ;;; @@ -166,3 +168,31 @@ there." (#f properties) (sexp `((provenance ,@sexp) ,@properties))))))))) + +(define (manifest-entry-provenance entry) + "Return the list of channels ENTRY comes from. Return the empty list if +that information is missing." + (match (assq-ref (manifest-entry-properties entry) 'provenance) + ((main extras ...) + ;; XXX: Until recently, channel sexps lacked the channel name. For + ;; entries created by 'manifest-entry-with-provenance', the first sexp + ;; is known to be the 'guix channel, and for the other ones, invent a + ;; fallback name (it's OK as the name is just a "pet name"). + (match (sexp->channel main 'guix) + (#f '()) + (channel + (let loop ((extras extras) + (counter 1) + (channels (list channel))) + (match extras + (() + (reverse channels)) + ((head . tail) + (let* ((name (string->symbol + (format #f "channel~a" counter))) + (extra (sexp->channel head name))) + (if extra + (loop tail (+ 1 counter) (cons extra channels)) + (loop tail counter channels))))))))) + (_ + '()))) diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 08b2bcf758..0da6fc19b6 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org> +;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -361,7 +362,9 @@ return the corresponding signature URL, or #f it signatures are unavailable." (let loop ((directory directory) (result #f)) - (let* ((entries (ftp-list conn directory)) + (let* ((entries (catch 'ftp-error + (lambda _ (ftp-list conn directory)) + (const '()))) ;; Filter out things like /gnupg/patches. Filter out "w32" ;; directories as found on ftp.gnutls.org. diff --git a/guix/import/gnu.scm b/guix/import/gnu.scm index 29324d7554..c26faff04b 100644 --- a/guix/import/gnu.scm +++ b/guix/import/gnu.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,8 +18,10 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix import gnu) + #:use-module ((guix diagnostics) #:select (formatted-message)) #:use-module (guix gnu-maintenance) #:use-module (guix import utils) + #:use-module (guix i18n) #:use-module (guix utils) #:use-module (guix store) #:use-module (gcrypt hash) @@ -113,15 +116,14 @@ details.)" (let ((version (upstream-source-version release))) (match (find-package name) (#f - (raise (condition - (&message - (message "couldn't find meta-data for GNU package"))))) + (raise (formatted-message + (G_ "couldn't find meta-data for GNU ~a") + name))) (info (gnu-package->sexp info release #:key-download key-download))))) (_ - (raise (condition - (&message - (message - "failed to determine latest release of GNU package"))))))) + (raise (formatted-message + (G_ "failed to determine latest release of GNU ~a") + name))))) ;;; gnu.scm ends here diff --git a/guix/inferior.scm b/guix/inferior.scm index 2fe91beaab..0990696e6c 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -40,6 +40,7 @@ #:use-module (guix search-paths) #:use-module (guix profiles) #:use-module (guix channels) + #:use-module ((guix git) #:select (update-cached-checkout)) #:use-module (guix monads) #:use-module (guix store) #:use-module (guix derivations) @@ -51,6 +52,7 @@ #:autoload (guix build utils) (mkdir-p) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-71) #:autoload (ice-9 ftw) (scandir) #:use-module (ice-9 match) #:use-module (ice-9 popen) @@ -311,8 +313,7 @@ Raise '&inferior-exception' when an exception is read from PORT." "Return the list of name/version pairs corresponding to the set of packages available in INFERIOR. -This is faster and requires less resource-intensive than calling -'inferior-packages'." +This is faster and less resource-intensive than calling 'inferior-packages'." (if (inferior-eval '(defined? 'fold-available-packages) inferior) (inferior-eval '(fold-available-packages @@ -642,29 +643,45 @@ failing when GUIX is too old and lacks the 'guix repl' command." (define* (inferior-package->manifest-entry package #:optional (output "out") - #:key (parent (delay #f)) - (properties '())) + #:key (properties '())) "Return a manifest entry for the OUTPUT of package PACKAGE." - ;; For each dependency, keep a promise pointing to its "parent" entry. - (letrec* ((deps (map (match-lambda - ((label package) - (inferior-package->manifest-entry package - #:parent (delay entry))) - ((label package output) - (inferior-package->manifest-entry package output - #:parent (delay entry)))) - (inferior-package-propagated-inputs package))) - (entry (manifest-entry - (name (inferior-package-name package)) - (version (inferior-package-version package)) - (output output) - (item package) - (dependencies (delete-duplicates deps)) - (search-paths - (inferior-package-transitive-native-search-paths package)) - (parent parent) - (properties properties)))) - entry)) + (define cache + (make-hash-table)) + + (define-syntax-rule (memoized package output exp) + ;; Memoize the entry returned by EXP for PACKAGE/OUTPUT. This is + ;; important as the same package may be traversed many times through + ;; propagated inputs, and querying the inferior is costly. Use + ;; 'hash'/'equal?', which is okay since <inferior-package> is simple. + (let ((compute (lambda () exp)) + (key (cons package output))) + (or (hash-ref cache key) + (let ((result (compute))) + (hash-set! cache key result) + result)))) + + (let loop ((package package) + (output output) + (parent (delay #f))) + (memoized package output + ;; For each dependency, keep a promise pointing to its "parent" entry. + (letrec* ((deps (map (match-lambda + ((label package) + (loop package "out" (delay entry))) + ((label package output) + (loop package output (delay entry)))) + (inferior-package-propagated-inputs package))) + (entry (manifest-entry + (name (inferior-package-name package)) + (version (inferior-package-version package)) + (output output) + (item package) + (dependencies (delete-duplicates deps)) + (search-paths + (inferior-package-transitive-native-search-paths package)) + (parent parent) + (properties properties)))) + entry)))) ;;; @@ -676,6 +693,21 @@ failing when GUIX is too old and lacks the 'guix repl' command." (make-parameter (string-append (cache-directory #:ensure? #f) "/inferiors"))) +(define (channel-full-commit channel) + "Return the commit designated by CHANNEL as quickly as possible. If +CHANNEL's 'commit' field is a full SHA1, return it as-is; if it's a SHA1 +prefix, resolve it; and if 'commit' is unset, fetch CHANNEL's branch tip." + (let ((commit (channel-commit channel)) + (branch (channel-branch channel))) + (if (and commit (= (string-length commit) 40)) + commit + (let* ((ref (if commit `(commit . ,commit) `(branch . ,branch))) + (cache commit relation + (update-cached-checkout (channel-url channel) + #:ref ref + #:check-out? #f))) + commit)))) + (define* (cached-channel-instance store channels #:key @@ -686,15 +718,16 @@ failing when GUIX is too old and lacks the 'guix repl' command." The directory is a subdirectory of CACHE-DIRECTORY, where entries can be reclaimed after TTL seconds. This procedure opens a new connection to the build daemon. AUTHENTICATE? determines whether CHANNELS are authenticated." - (define instances - (latest-channel-instances store channels - #:authenticate? authenticate?)) + (define commits + ;; Since computing the instances of CHANNELS is I/O-intensive, use a + ;; cheaper way to get the commit list of CHANNELS. This limits overhead + ;; to the minimum in case of a cache hit. + (map channel-full-commit channels)) (define key (bytevector->base32-string (sha256 - (string->utf8 - (string-concatenate (map channel-instance-commit instances)))))) + (string->utf8 (string-concatenate commits))))) (define cached (string-append cache-directory "/" key)) @@ -722,8 +755,12 @@ determines whether CHANNELS are authenticated." (if (file-exists? cached) cached (run-with-store store - (mlet %store-monad ((profile - (channel-instances->derivation instances))) + (mlet* %store-monad ((instances + -> (latest-channel-instances store channels + #:authenticate? + authenticate?)) + (profile + (channel-instances->derivation instances))) (mbegin %store-monad (show-what-to-build* (list profile)) (built-derivations (list profile)) @@ -750,3 +787,7 @@ This is a convenience procedure that people may use in manifests passed to #:cache-directory cache-directory #:ttl ttl))) (open-inferior cached)) + +;;; Local Variables: +;;; eval: (put 'memoized 'scheme-indent-function 1) +;;; End: diff --git a/guix/licenses.scm b/guix/licenses.scm index 63010a7231..1091eee67c 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -61,7 +61,7 @@ gpl1 gpl1+ gpl2 gpl2+ gpl3 gpl3+ gfl1.0 fdl1.1+ fdl1.2+ fdl1.3+ - opl1.0+ + opl1.0+ osl2.1 isc ijg ibmpl1.0 @@ -371,6 +371,11 @@ at URI, which may be a file:// URI pointing the package's tree." "http://opencontent.org/openpub/" "https://www.gnu.org/licenses/license-list#OpenPublicationL")) +(define osl2.1 + (license "The Open Software License 2.1" + "https://opensource.org/licenses/osl-2.1.php" + "https://www.gnu.org/licenses/license-list#OSL")) + (define isc (license "ISC" "http://directory.fsf.org/wiki/License:ISC" diff --git a/guix/profiles.scm b/guix/profiles.scm index 59a313ea08..ea8bc6e593 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> @@ -107,6 +107,8 @@ manifest-search-paths check-for-collisions + manifest->code + manifest-transaction manifest-transaction? manifest-transaction-install @@ -667,6 +669,88 @@ including the search path specification for $PATH." (append-map manifest-entry-search-paths (manifest-entries manifest))))) +(define* (manifest->code manifest + #:key (entry-package-version (const ""))) + "Return an sexp representing code to build an approximate version of +MANIFEST; the code is wrapped in a top-level 'begin' form. Call +ENTRY-PACKAGE-VERSION to determine the version number to use in the spec for a +given entry; it can be set to 'manifest-entry-version' for fully-specified +version numbers, or to some other procedure to disambiguate versions for +packages for which several versions are available." + (define (entry-transformations entry) + ;; Return the transformations that apply to ENTRY. + (assoc-ref (manifest-entry-properties entry) 'transformations)) + + (define transformation-procedures + ;; List of transformation options/procedure name pairs. + (let loop ((entries (manifest-entries manifest)) + (counter 1) + (result '())) + (match entries + (() result) + ((entry . tail) + (match (entry-transformations entry) + (#f + (loop tail counter result)) + (options + (if (assoc-ref result options) + (loop tail counter result) + (loop tail (+ 1 counter) + (alist-cons options + (string->symbol + (format #f "transform~a" counter)) + result))))))))) + + (define (qualified-name entry) + ;; Return the name of ENTRY possibly with "@" followed by a version. + (match (entry-package-version entry) + ("" (manifest-entry-name entry)) + (version (string-append (manifest-entry-name entry) + "@" version)))) + + (if (null? transformation-procedures) + `(begin ;simplest case + (specifications->manifest + (list ,@(map (lambda (entry) + (match (manifest-entry-output entry) + ("out" (qualified-name entry)) + (output (string-append (qualified-name entry) + ":" output)))) + (manifest-entries manifest))))) + (let* ((transform (lambda (options exp) + (if (not options) + exp + (let ((proc (assoc-ref transformation-procedures + options))) + `(,proc ,exp)))))) + `(begin ;transformations apply + (use-modules (guix transformations)) + + ,@(map (match-lambda + ((options . name) + `(define ,name + (options->transformation ',options)))) + transformation-procedures) + + (packages->manifest + (list ,@(map (lambda (entry) + (define options + (entry-transformations entry)) + + (define name + (qualified-name entry)) + + (match (manifest-entry-output entry) + ("out" + (transform options + `(specification->package ,name))) + (output + `(list ,(transform + options + `(specification->package ,name)) + ,output)))) + (manifest-entries manifest)))))))) + ;;; ;;; Manifest transactions. diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm index c3667516eb..e47d207ee0 100644 --- a/guix/scripts/describe.scm +++ b/guix/scripts/describe.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com> ;;; Copyright © 2020 Ekaitz Zarraga <ekaitz@elenq.tech> ;;; @@ -113,22 +113,6 @@ Display information about the channels currently in use.\n")) (_ (warning (G_ "'GUIX_PACKAGE_PATH' is set but it is not captured~%"))))))) -(define* (channel->sexp channel #:key (include-introduction? #t)) - (let ((intro (and include-introduction? - (channel-introduction channel)))) - `(channel - (name ',(channel-name channel)) - (url ,(channel-url channel)) - (commit ,(channel-commit channel)) - ,@(if intro - `((introduction (make-channel-introduction - ,(channel-introduction-first-signed-commit intro) - (openpgp-fingerprint - ,(openpgp-format-fingerprint - (channel-introduction-first-commit-signer - intro)))))) - '())))) - (define (channel->json channel) (scm->json-string (let ((intro (channel-introduction channel))) @@ -183,7 +167,7 @@ string is ~a.~%") (format #t (G_ " branch: ~a~%") (reference-shorthand head)) (format #t (G_ " commit: ~a~%") commit)) ('channels - (pretty-print `(list ,(channel->sexp (channel (name 'guix) + (pretty-print `(list ,(channel->code (channel (name 'guix) (url (dirname directory)) (commit commit)))))) ('json @@ -213,9 +197,9 @@ in the format specified by FMT." ('human (display-profile-content profile number)) ('channels - (pretty-print `(list ,@(map channel->sexp channels)))) + (pretty-print `(list ,@(map channel->code channels)))) ('channels-sans-intro - (pretty-print `(list ,@(map (cut channel->sexp <> + (pretty-print `(list ,@(map (cut channel->code <> #:include-introduction? #f) channels)))) ('json @@ -237,23 +221,17 @@ way and displaying details about the channel's source code." (format #t " ~a ~a~%" (manifest-entry-name entry) (manifest-entry-version entry)) - (match (assq 'source (manifest-entry-properties entry)) - (('source ('repository ('version 0) - ('url url) - ('branch branch) - ('commit commit) - _ ...)) - (let ((channel (channel (name 'nameless) - (url url) - (branch branch) - (commit commit)))) - (format #t (G_ " repository URL: ~a~%") url) - (when branch - (format #t (G_ " branch: ~a~%") branch)) - (format #t (G_ " commit: ~a~%") - (if (supports-hyperlinks?) - (channel-commit-hyperlink channel commit) - commit)))) + (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. diff --git a/guix/scripts/import/json.scm b/guix/scripts/import/json.scm index 778e5f4bc5..d8d5c3a4af 100644 --- a/guix/scripts/import/json.scm +++ b/guix/scripts/import/json.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2015, 2017 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -88,8 +89,13 @@ Import and convert the JSON package definition in PACKAGE-FILE.\n")) (reverse opts)))) (match args ((file-name) - (or (json->code file-name) - (leave (G_ "invalid JSON in file '~a'~%") file-name))) + (catch 'system-error + (lambda () + (or (json->code file-name) + (leave (G_ "invalid JSON in file '~a'~%") file-name))) + (lambda args + (leave (G_ "failed to access '~a': ~a~%") + file-name (strerror (system-error-errno args)))))) (() (leave (G_ "too few arguments~%"))) ((many ...) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 6faf2adb7a..8234a1703d 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2013, 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com> @@ -43,11 +43,13 @@ #:use-module (guix scripts build) #:use-module (guix transformations) #:use-module (guix describe) + #:autoload (guix channels) (channel-name channel-commit channel->code) #:autoload (guix store roots) (gc-roots user-owned?) #:use-module ((guix build utils) #:select (directory-exists? mkdir-p)) #:use-module (ice-9 format) #:use-module (ice-9 match) + #:autoload (ice-9 pretty-print) (pretty-print) #:use-module (ice-9 regex) #:use-module (ice-9 vlist) #:use-module (srfi srfi-1) @@ -322,6 +324,96 @@ Alternately, see @command{guix package --search-paths -p ~s}.") ;;; +;;; Export a manifest. +;;; + +(define* (export-manifest manifest + #:optional (port (current-output-port))) + "Write to PORT a manifest corresponding to MANIFEST." + (define (version-spec entry) + (let ((name (manifest-entry-name entry))) + (match (map package-version (find-packages-by-name name)) + ((_) + ;; A single version of NAME is available, so do not specify the + ;; version number, even if the available version doesn't match ENTRY. + "") + (versions + ;; If ENTRY uses the latest version, don't specify any version. + ;; Otherwise return the shortest unique version prefix. Note that + ;; this is based on the currently available packages, which could + ;; differ from the packages available in the revision that was used + ;; to build MANIFEST. + (let ((current (manifest-entry-version entry))) + (if (every (cut version>? current <>) + (delete current versions)) + "" + (version-unique-prefix (manifest-entry-version entry) + versions))))))) + + (match (manifest->code manifest + #:entry-package-version version-spec) + (('begin exp ...) + (format port (G_ "\ +;; This \"manifest\" file can be passed to 'guix package -m' to reproduce +;; the content of your profile. This is \"symbolic\": it only specifies +;; package names. To reproduce the exact same profile, you also need to +;; capture the channels being used, as returned by \"guix describe\". +;; See the \"Replicating Guix\" section in the manual.\n")) + (for-each (lambda (exp) + (newline port) + (pretty-print exp port)) + exp)))) + +(define (channel=? a b) + (and (channel-commit a) (channel-commit b) + (string=? (channel-commit a) (channel-commit b)))) + +(define* (export-channels manifest + #:optional (port (current-output-port))) + (define channels + (delete-duplicates + (append-map manifest-entry-provenance (manifest-entries manifest)) + channel=?)) + + (define channel-names + (delete-duplicates (map channel-name channels))) + + (define table + (fold (lambda (channel table) + (vhash-consq (channel-name channel) channel table)) + vlist-null + channels)) + + (when (null? channels) + (leave (G_ "no provenance information for this profile~%"))) + + (format port (G_ "\ +;; This channel file can be passed to 'guix pull -C' or to +;; 'guix time-machine -C' to obtain the Guix revision that was +;; used to populate this profile.\n")) + (newline port) + (display "(list\n" port) + (for-each (lambda (name) + (define indent " ") + (match (vhash-foldq* cons '() name table) + ((channel extra ...) + (unless (null? extra) + (display indent port) + (format port (G_ "\ +;; Note: these other commits were also used to install \ +some of the packages in this profile:~%")) + (for-each (lambda (channel) + (format port "~a;; ~s~%" + indent (channel-commit channel))) + extra)) + (pretty-print (channel->code channel) port + #:per-line-prefix indent)))) + channel-names) + (display ")\n" port) + #t) + + +;;; ;;; Command-line options. ;;; @@ -374,6 +466,10 @@ Install, remove, or upgrade packages in a single transaction.\n")) -S, --switch-generation=PATTERN switch to a generation matching PATTERN")) (display (G_ " + --export-manifest print a manifest for the chosen profile")) + (display (G_ " + --export-channels print channels for the chosen profile")) + (display (G_ " -p, --profile=PROFILE use PROFILE instead of the user's default profile")) (display (G_ " --list-profiles list the user's profiles")) @@ -507,6 +603,14 @@ kind of search path~%") (values (cons `(query search-paths ,kind) result) #f)))) + (option '("export-manifest") #f #f + (lambda (opt name arg result arg-handler) + (values (cons `(query export-manifest) result) + #f))) + (option '("export-channels") #f #f + (lambda (opt name arg result arg-handler) + (values (cons `(query export-channels) result) + #f))) (option '(#\p "profile") #t #f (lambda (opt name arg result arg-handler) (values (alist-cons 'profile (canonicalize-profile arg) @@ -827,6 +931,18 @@ processed, #f otherwise." (format #t "~{~a~%~}" settings) #t)) + (('export-manifest) + (let* ((manifest (concatenate-manifests + (map profile-manifest profiles)))) + (export-manifest manifest (current-output-port)) + #t)) + + (('export-channels) + (let ((manifest (concatenate-manifests + (map profile-manifest profiles)))) + (export-channels manifest (current-output-port)) + #t)) + (_ #f)))) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 83cdc1d1eb..4e0ab5d341 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -765,60 +765,61 @@ Use '~/.config/guix/channels.scm' instead.")) #:argument-handler no-arguments)) (substitutes? (assoc-ref opts 'substitutes?)) (dry-run? (assoc-ref opts 'dry-run?)) - (channels (channel-list opts)) (profile (or (assoc-ref opts 'profile) %current-profile)) (current-channels (profile-channels profile)) (validate-pull (assoc-ref opts 'validate-pull)) (authenticate? (assoc-ref opts 'authenticate-channels?))) - (cond ((assoc-ref opts 'query) - (process-query opts profile)) - ((assoc-ref opts 'generation) - (process-generation-change opts profile)) - (else - (with-store store - (with-status-verbosity (assoc-ref opts 'verbosity) - (parameterize ((%current-system (assoc-ref opts 'system)) - (%graft? (assoc-ref opts 'graft?))) - (with-build-handler (build-notifier #:use-substitutes? - substitutes? - #:verbosity - (assoc-ref opts 'verbosity) - #:dry-run? dry-run?) - (set-build-options-from-command-line store opts) - (ensure-default-profile) - (honor-x509-certificates store) + (cond + ((assoc-ref opts 'query) + (process-query opts profile)) + ((assoc-ref opts 'generation) + (process-generation-change opts profile)) + (else + (with-store store + (with-status-verbosity (assoc-ref opts 'verbosity) + (parameterize ((%current-system (assoc-ref opts 'system)) + (%graft? (assoc-ref opts 'graft?))) + (with-build-handler (build-notifier #:use-substitutes? + substitutes? + #:verbosity + (assoc-ref opts 'verbosity) + #:dry-run? dry-run?) + (set-build-options-from-command-line store opts) + (ensure-default-profile) + (honor-x509-certificates store) - (let ((instances - (latest-channel-instances store channels - #:current-channels - current-channels - #:validate-pull - validate-pull - #:authenticate? - authenticate?))) - (format (current-error-port) - (N_ "Building from this channel:~%" - "Building from these channels:~%" - (length instances))) - (for-each (lambda (instance) - (let ((channel - (channel-instance-channel instance))) - (format (current-error-port) - " ~10a~a\t~a~%" - (channel-name channel) - (channel-url channel) - (string-take - (channel-instance-commit instance) - 7)))) - instances) - (parameterize ((%guile-for-build - (package-derivation - store - (if (assoc-ref opts 'bootstrap?) - %bootstrap-guile - (default-guile))))) - (with-profile-lock profile - (run-with-store store - (build-and-install instances profile))))))))))))))) + (let* ((channels (channel-list opts)) + (instances + (latest-channel-instances store channels + #:current-channels + current-channels + #:validate-pull + validate-pull + #:authenticate? + authenticate?))) + (format (current-error-port) + (N_ "Building from this channel:~%" + "Building from these channels:~%" + (length instances))) + (for-each (lambda (instance) + (let ((channel + (channel-instance-channel instance))) + (format (current-error-port) + " ~10a~a\t~a~%" + (channel-name channel) + (channel-url channel) + (string-take + (channel-instance-commit instance) + 7)))) + instances) + (parameterize ((%guile-for-build + (package-derivation + store + (if (assoc-ref opts 'bootstrap?) + %bootstrap-guile + (default-guile))))) + (with-profile-lock profile + (run-with-store store + (build-and-install instances profile))))))))))))))) ;;; pull.scm ends here diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 66225bff35..19b8c5163c 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -915,7 +915,8 @@ Run 'herd status' to view the list of services on your system.\n")))))) (let* ((services (operating-system-services os)) (pid1 (fold-services services #:target-type shepherd-root-service-type)) - (shepherds (service-value pid1)) ;list of <shepherd-service> + ;; Get the list of <shepherd-service>. + (shepherds (shepherd-configuration-services (service-value pid1))) (sinks (filter (lambda (service) (null? (shepherd-service-requirement service))) shepherds))) diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm index 5581e12892..39a818dd0b 100644 --- a/guix/scripts/system/reconfigure.scm +++ b/guix/scripts/system/reconfigure.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Alex Kost <alezost@gmail.com> ;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> @@ -177,9 +177,10 @@ canonical names (symbols)." upgrade the Shepherd (PID 1) by unloading obsolete services and loading new services as defined by OS." (define target-services - (service-value - (fold-services (operating-system-services os) - #:target-type shepherd-root-service-type))) + (shepherd-configuration-services + (service-value + (fold-services (operating-system-services os) + #:target-type shepherd-root-service-type)))) (mlet* %store-monad ((live-services (running-services eval))) (let*-values (((to-unload to-restart) diff --git a/guix/store/database.scm b/guix/store/database.scm index 0a84bbddb9..8d08def833 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017, 2019 Caleb Ristvedt <caleb.ristvedt@cune.org> -;;; Copyright © 2018, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; ;;; This file is part of GNU Guix. @@ -53,20 +53,6 @@ ;; Name of the file containing the SQL scheme or #f. (make-parameter #f)) -(define sqlite-exec - ;; XXX: This is was missing from guile-sqlite3 until - ;; <https://notabug.org/guile-sqlite3/guile-sqlite3/commit/b87302f9bcd18a286fed57b2ea521845eb1131d7>. - (let ((exec (pointer->procedure - int - (dynamic-func "sqlite3_exec" (@@ (sqlite3) libsqlite3)) - '(* * * * *)))) - (lambda (db text) - (let ((ret (exec ((@@ (sqlite3) db-pointer) db) - (string->pointer text) - %null-pointer %null-pointer %null-pointer))) - (unless (zero? ret) - ((@@ (sqlite3) sqlite-error) db "sqlite-exec" ret)))))) - (define* (store-database-directory #:key prefix state-directory) "Return the store database directory, taking PREFIX and STATE-DIRECTORY into account when provided." @@ -126,7 +112,7 @@ set journal_mode=WAL." (lambda () (sqlite-close db))))) -;; XXX: missing in guile-sqlite3@0.1.0 +;; XXX: missing in guile-sqlite3@0.1.2 (define SQLITE_BUSY 5) (define (call-with-SQLITE_BUSY-retrying thunk) @@ -139,8 +125,6 @@ errors." (call-with-SQLITE_BUSY-retrying thunk) (throw key who code errmsg))))) - - (define* (call-with-transaction db proc #:key restartable?) "Start a transaction with DB and run PROC. If PROC exits abnormally, abort the transaction, otherwise commit the transaction after it finishes. @@ -214,17 +198,6 @@ If FILE doesn't exist, create it and initialize it as a new database. Pass ((_ file db exp ...) (call-with-database file (lambda (db) exp ...))))) -(define (sqlite-finalize stmt) - ;; As of guile-sqlite3 0.1.0, cached statements aren't reset when - ;; sqlite-finalize is invoked on them (see - ;; https://notabug.org/guile-sqlite3/guile-sqlite3/issues/12). This can - ;; cause problems with automatically-started transactions, so we work around - ;; it by wrapping sqlite-finalize so that sqlite-reset is always called. - ;; This always works, because resetting a statement twice has no adverse - ;; effects. We can remove this once the fixed guile-sqlite3 is widespread. - (sqlite-reset stmt) - ((@ (sqlite3) sqlite-finalize) stmt)) - (define (call-with-statement db sql proc) (let ((stmt (sqlite-prepare db sql #:cache? #t))) (dynamic-wind @@ -268,12 +241,26 @@ identifier. Otherwise, return #f." "INSERT INTO ValidPaths (path, hash, registrationTime, deriver, narSize) VALUES (:path, :hash, :time, :deriver, :size)") +(define-inlinable (assert-integer proc in-range? key number) + (unless (integer? number) + (throw 'wrong-type-arg proc + "Wrong type argument ~A: ~S" (list key number) + (list number))) + (unless (in-range? number) + (throw 'out-of-range proc + "Integer ~A out of range: ~S" (list key number) + (list number)))) + (define* (update-or-insert db #:key path deriver hash nar-size time) "The classic update-if-exists and insert-if-doesn't feature that sqlite doesn't exactly have... they've got something close, but it involves deleting and re-inserting instead of updating, which causes problems with foreign keys, of course. Returns the row id of the row that was modified or inserted." + ;; Make sure NAR-SIZE is valid. + (assert-integer "update-or-insert" positive? #:nar-size nar-size) + (assert-integer "update-or-insert" (cut >= <> 0) #:time time) + ;; It's important that querying the path-id and the insert/update operation ;; take place in the same transaction, as otherwise some other ;; process/thread/fiber could register the same path between when we check diff --git a/guix/ui.scm b/guix/ui.scm index bd504c68da..45ae14f83c 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -2124,24 +2124,20 @@ Run COMMAND with ARGS.\n")) "Run COMMAND with the given ARGS. Report an error when COMMAND is not found." (define module - (catch 'misc-error - (lambda () - (resolve-interface `(guix scripts ,command))) - (lambda _ - ;; Check if there is a matching extension. - (catch 'misc-error - (lambda () - (match (search-path (extension-directories) - (format #f "~a.scm" command)) - (#f - (throw 'misc-error)) - (file - (load file) - (resolve-interface `(guix extensions ,command))))) - (lambda _ - (format (current-error-port) - (G_ "guix: ~a: command not found~%") command) - (show-guix-usage)))))) + ;; Check if there is a matching extension. + (match (search-path (extension-directories) + (format #f "~a.scm" command)) + (#f + (catch 'misc-error + (lambda () + (resolve-interface `(guix scripts ,command))) + (lambda _ + (format (current-error-port) + (G_ "guix: ~a: command not found~%") command) + (show-guix-usage)))) + (file + (load file) + (resolve-interface `(guix extensions ,command))))) (let ((command-main (module-ref module (symbol-append 'guix- command)))) diff --git a/guix/utils.scm b/guix/utils.scm index f8b05e7e80..a85e2f495c 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013, 2014, 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2014 Ian Denhardt <ian@zenhack.net> @@ -88,6 +88,7 @@ version-major+minor+point version-major+minor version-major + version-unique-prefix guile-version>? version-prefix? string-replace-substring @@ -589,6 +590,38 @@ minor version numbers from version-string." "Return the major version number as string from the version-string." (version-prefix version-string 1)) +(define (version-unique-prefix version versions) + "Return the shortest version prefix to unambiguously identify VERSION among +VERSIONS. For example: + + (version-unique-prefix \"2.0\" '(\"3.0\" \"2.0\")) + => \"2\" + + (version-unique-prefix \"2.2\" '(\"3.0.5\" \"2.0.9\" \"2.2.7\")) + => \"2.2\" + + (version-unique-prefix \"27.1\" '(\"27.1\")) + => \"\" +" + (define not-dot + (char-set-complement (char-set #\.))) + + (define other-versions + (delete version versions)) + + (let loop ((prefix '()) + (components (string-tokenize version not-dot))) + (define prefix-str + (string-join prefix ".")) + + (if (any (cut string-prefix? prefix-str <>) other-versions) + (match components + ((head . tail) + (loop `(,@prefix ,head) tail)) + (() + version)) + prefix-str))) + (define (version>? a b) "Return #t when A denotes a version strictly newer than B." (eq? '> (version-compare a b))) |