From a4678c6ba18d8dbd79d931f80426eebf61be7ebe Mon Sep 17 00:00:00 2001 From: Caleb Ristvedt Date: Wed, 30 Jan 2019 17:03:38 -0600 Subject: database: Make 'register-items' transactional. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/store/database.scm (SQLITE_BUSY, register-output-sql): New variables. (add-references): Don't try finalizing after each use, only after all the uses (otherwise a finalized statement would be used if #:cache? was #f). (call-with-transaction): New procedure. (register-items): Use call-with-transaction to prevent broken intermediate states from being visible. * .dir-locals.el (call-with-transaction): indent it. Signed-off-by: Ludovic Courtès --- guix/store/database.scm | 52 +++++++++++++++++++++++++++++++++++++------------ 1 file changed, 40 insertions(+), 12 deletions(-) (limited to 'guix') diff --git a/guix/store/database.scm b/guix/store/database.scm index 4791f49865..88d05dc42e 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017 Caleb Ristvedt +;;; Copyright © 2017, 2019 Caleb Ristvedt ;;; Copyright © 2018 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. @@ -96,6 +96,31 @@ create it and initialize it as a new database." (lambda () (sqlite-close db))))) +;; XXX: missing in guile-sqlite3@0.1.0 +(define SQLITE_BUSY 5) + +(define (call-with-transaction db proc) + "Start a transaction with DB (make as many attempts as necessary) and run +PROC. If PROC exits abnormally, abort the transaction, otherwise commit the +transaction after it finishes." + (catch 'sqlite-error + (lambda () + ;; We use begin immediate here so that if we need to retry, we + ;; figure that out immediately rather than because some SQLITE_BUSY + ;; exception gets thrown partway through PROC - in which case the + ;; part already executed (which may contain side-effects!) would be + ;; executed again for every retry. + (sqlite-exec db "begin immediate;") + (let ((result (proc))) + (sqlite-exec db "commit;") + result)) + (lambda (key who error description) + (if (= error SQLITE_BUSY) + (call-with-transaction db proc) + (begin + (sqlite-exec db "rollback;") + (throw 'sqlite-error who error description)))))) + (define %default-database-file ;; Default location of the store database. (string-append %store-database-directory "/db.sqlite")) @@ -172,9 +197,9 @@ ids of items referred to." (sqlite-bind-arguments stmt #:referrer referrer #:reference reference) (sqlite-fold cons '() stmt) ;execute it - (sqlite-finalize stmt) (last-insert-row-id db)) - references))) + references) + (sqlite-finalize stmt))) (define* (sqlite-register db #:key path (references '()) deriver hash nar-size time) @@ -305,6 +330,7 @@ Write a progress report to LOG-PORT." (define real-file-name (string-append store-dir "/" (basename (store-info-item item)))) + ;; When TO-REGISTER is already registered, skip it. This makes a ;; significant differences when 'register-closures' is called ;; consecutively for overlapping closures such as 'system' and 'bootcfg'. @@ -325,12 +351,14 @@ Write a progress report to LOG-PORT." (mkdir-p db-dir) (parameterize ((sql-schema schema)) (with-database (string-append db-dir "/db.sqlite") db - (let* ((prefix (format #f "registering ~a items" (length items))) - (progress (progress-reporter/bar (length items) - prefix log-port))) - (call-with-progress-reporter progress - (lambda (report) - (for-each (lambda (item) - (register db item) - (report)) - items))))))) + (call-with-transaction db + (lambda () + (let* ((prefix (format #f "registering ~a items" (length items))) + (progress (progress-reporter/bar (length items) + prefix log-port))) + (call-with-progress-reporter progress + (lambda (report) + (for-each (lambda (item) + (register db item) + (report)) + items))))))))) -- cgit v1.2.3 From 2cb658a9a7c491ee8ea13da9682170e40deb25ed Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 6 Mar 2019 23:48:41 +0100 Subject: describe: Add 'package-provenance'. * guix/scripts/package.scm (package-provenance): Move to... * guix/describe.scm (package-provenance): ... here. --- guix/describe.scm | 43 +++++++++++++++++++++++++++++++++++++++++-- guix/scripts/package.scm | 36 +----------------------------------- 2 files changed, 42 insertions(+), 37 deletions(-) (limited to 'guix') diff --git a/guix/describe.scm b/guix/describe.scm index 670db63ce7..c31199c9cd 100644 --- a/guix/describe.scm +++ b/guix/describe.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018 Ludovic Courtès +;;; Copyright © 2018, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,11 +19,16 @@ (define-module (guix describe) #:use-module (guix memoization) #:use-module (guix profiles) + #:use-module (guix packages) + #:use-module ((guix utils) #:select (location-file)) + #:use-module ((guix store) #:select (%store-prefix)) #:use-module (srfi srfi-1) #:use-module (ice-9 match) #:export (current-profile current-profile-entries - package-path-entries)) + package-path-entries + + package-provenance)) ;;; Commentary: ;;; @@ -73,3 +78,37 @@ process lives in, when applicable." "/share/guile/site/" (effective-version)))) (current-profile-entries)))) + +(define (package-provenance package) + "Return the provenance of PACKAGE as an sexp for use as the 'provenance' +property of manifest entries, or #f if it could not be determined." + (define (entry-source entry) + (match (assq 'source + (manifest-entry-properties entry)) + (('source value) value) + (_ #f))) + + (match (and=> (package-location package) location-file) + (#f #f) + (file + (let ((file (if (string-prefix? "/" file) + file + (search-path %load-path file)))) + (and file + (string-prefix? (%store-prefix) file) + + ;; Always store information about the 'guix' channel and + ;; optionally about the specific channel FILE comes from. + (or (let ((main (and=> (find (lambda (entry) + (string=? "guix" + (manifest-entry-name entry))) + (current-profile-entries)) + entry-source)) + (extra (any (lambda (entry) + (let ((item (manifest-entry-item entry))) + (and (string-prefix? item file) + (entry-source entry)))) + (current-profile-entries)))) + (and main + `(,main + ,@(if extra (list extra) '())))))))))) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 0e70315708..efff511299 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -36,7 +36,7 @@ #:use-module (guix config) #:use-module (guix scripts) #:use-module (guix scripts build) - #:autoload (guix describe) (current-profile-entries) + #:autoload (guix describe) (package-provenance) #:use-module ((guix build utils) #:select (directory-exists? mkdir-p)) #:use-module (ice-9 format) @@ -552,40 +552,6 @@ upgrading, #f otherwise." (output "out") ;XXX: wild guess (item item)))) -(define (package-provenance package) - "Return the provenance of PACKAGE as an sexp for use as the 'provenance' -property of manifest entries, or #f if it could not be determined." - (define (entry-source entry) - (match (assq 'source - (manifest-entry-properties entry)) - (('source value) value) - (_ #f))) - - (match (and=> (package-location package) location-file) - (#f #f) - (file - (let ((file (if (string-prefix? "/" file) - file - (search-path %load-path file)))) - (and file - (string-prefix? (%store-prefix) file) - - ;; Always store information about the 'guix' channel and - ;; optionally about the specific channel FILE comes from. - (or (let ((main (and=> (find (lambda (entry) - (string=? "guix" - (manifest-entry-name entry))) - (current-profile-entries)) - entry-source)) - (extra (any (lambda (entry) - (let ((item (manifest-entry-item entry))) - (and (string-prefix? item file) - (entry-source entry)))) - (current-profile-entries)))) - (and main - `(,main - ,@(if extra (list extra) '())))))))))) - (define (package->manifest-entry* package output) "Like 'package->manifest-entry', but attach PACKAGE provenance meta-data to the resulting manifest entry." -- cgit v1.2.3 From d40ec4a0d00df08ec4f866467080235f5a9fea87 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 6 Mar 2019 23:53:08 +0100 Subject: pack: Add '--save-provenance'. * guix/scripts/pack.scm (show-help, %options): Add '--save-provenance'. (guix-pack)[manifest-from-args]: Honor it. * doc/guix.texi (Invoking guix pack): Document it. --- doc/guix.texi | 17 +++++++++++++++++ guix/scripts/pack.scm | 27 ++++++++++++++++++++++++++- 2 files changed, 43 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 1b77881eb6..0f325fb542 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -4777,6 +4777,23 @@ symlink target. For instance, @code{-S /opt/gnu/bin=bin} creates a @file{/opt/gnu/bin} symlink pointing to the @file{bin} sub-directory of the profile. +@item --save-provenance +Save provenance information for the packages passed on the command line. +Provenance information includes the URL and commit of the channels in use +(@pxref{Channels}). + +Provenance information is saved in the +@file{/gnu/store/@dots{}-profile/manifest} file in the pack, along with the +usual package metadata---the name and version of each package, their +propagated inputs, and so on. It is useful information to the recipient of +the pack, who then knows how the pack was (supposedly) obtained. + +This option is not enabled by default because, like timestamps, provenance +information contributes nothing to the build process. In other words, there +is an infinity of channel URLs and commit IDs that can lead to the same pack. +Recording such ``silent'' metadata in the output thus potentially breaks the +source-to-binary bitwise reproducibility property. + @item --localstatedir @itemx --profile-name=@var{name} Include the ``local state directory'', @file{/var/guix}, in the resulting diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 86e15d9bab..e2ecddfbfc 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -32,6 +32,7 @@ #:use-module (guix modules) #:use-module (guix packages) #:use-module (guix profiles) + #:use-module (guix describe) #:use-module (guix derivations) #:use-module (guix search-paths) #:use-module (guix build-system gnu) @@ -678,6 +679,9 @@ please email '~a'~%") (x (leave (G_ "~a: invalid symlink specification~%") arg))))) + (option '("save-provenance") #f #f + (lambda (opt name arg result) + (alist-cons 'save-provenance? #t result))) (option '("localstatedir") #f #f (lambda (opt name arg result) (alist-cons 'localstatedir? #t result))) @@ -725,6 +729,8 @@ Create a bundle of PACKAGE.\n")) -S, --symlink=SPEC create symlinks to the profile according to SPEC")) (display (G_ " -m, --manifest=FILE create a pack with the manifest from FILE")) + (display (G_ " + --save-provenance save provenance information")) (display (G_ " --localstatedir include /var/guix in the resulting pack")) (display (G_ " @@ -772,13 +778,32 @@ Create a bundle of PACKAGE.\n")) (list (transform store package) "out"))) (filter-map maybe-package-argument opts))) (manifest-file (assoc-ref opts 'manifest))) + (define properties + (if (assoc-ref opts 'save-provenance?) + (lambda (package) + (match (package-provenance package) + (#f + (warning (G_ "could not determine provenance of package ~a~%") + (package-full-name package)) + '()) + (sexp + `((provenance . ,sexp))))) + (const '()))) + (cond ((and manifest-file (not (null? packages))) (leave (G_ "both a manifest and a package list were given~%"))) (manifest-file (let ((user-module (make-user-module '((guix profiles) (gnu))))) (load* manifest-file user-module))) - (else (packages->manifest packages))))) + (else + (manifest + (map (match-lambda + ((package output) + (package->manifest-entry package output + #:properties + (properties package)))) + packages)))))) (with-error-handling (with-store store -- cgit v1.2.3 From 4035fcba93aaf551f4b5698045f025aa61287e17 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 8 Mar 2019 12:25:25 +0100 Subject: channels: Do not fail when the inferior lacks 'guix repl'. Fixes . Reported by Martin Flack . Previously we'd fail to build the package cache for old versions of Guix that lack 'guix repl'. Now we simply ignore the issue and keep going without a cache. * guix/inferior.scm (gexp->derivation-in-inferior): Add #:silent-failure? and honor it. [drop-extra-keyword]: New procedure. Use it. * guix/channels.scm (package-cache-file): Pass #:silent-failure? #t. --- guix/channels.scm | 6 ++++++ guix/inferior.scm | 27 +++++++++++++++++++++++---- 2 files changed, 29 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/channels.scm b/guix/channels.scm index 96d62ce062..9658cf9393 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -477,6 +477,12 @@ be used as a profile hook." (gexp->derivation-in-inferior "guix-package-cache" build profile + + ;; If the Guix in PROFILE is too old and + ;; lacks 'guix repl', don't build the cache + ;; instead of failing. + #:silent-failure? #t + #:properties '((type . profile-hook) (hook . package-cache)) #:local-build? #t))) diff --git a/guix/inferior.scm b/guix/inferior.scm index 027418a98d..63c95141d7 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -513,10 +513,15 @@ PACKAGE must be live." (inferior-package->derivation package system #:target target)) (define* (gexp->derivation-in-inferior name exp guix + #:key silent-failure? + #:allow-other-keys #:rest rest) "Return a derivation that evaluates EXP with GUIX, an instance of Guix as returned for example by 'channel-instances->derivation'. Other arguments are -passed as-is to 'gexp->derivation'." +passed as-is to 'gexp->derivation'. + +When SILENT-FAILURE? is true, create an empty output directory instead of +failing when GUIX is too old and lacks the 'guix repl' command." (define script ;; EXP wrapped with a proper (set! %load-path …) prologue. (scheme-file "inferior-script.scm" exp)) @@ -539,9 +544,23 @@ passed as-is to 'gexp->derivation'." (write `(primitive-load #$script) pipe) (unless (zero? (close-pipe pipe)) - (error "inferior failed" #+guix))))) - - (apply gexp->derivation name trampoline rest)) + (if #$silent-failure? + (mkdir #$output) + (error "inferior failed" #+guix)))))) + + (define (drop-extra-keyword lst) + (let loop ((lst lst) + (result '())) + (match lst + (() + (reverse result)) + ((#:silent-failure? _ . rest) + (loop rest result)) + ((kw value . tail) + (loop tail (cons* value kw result)))))) + + (apply gexp->derivation name trampoline + (drop-extra-keyword rest))) ;;; -- cgit v1.2.3 From 8057c9e906fefb8df9ef94a83a644c9d7b1b0cd0 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Fri, 8 Mar 2019 23:18:01 +0100 Subject: gnu: Add epl2.0. * guix/licenses.scm (epl2.0): New variable. --- guix/licenses.scm | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'guix') diff --git a/guix/licenses.scm b/guix/licenses.scm index 4ef3ed188c..d22c3fa36e 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -50,6 +50,7 @@ cpl1.0 edl1.0 epl1.0 + epl2.0 expat freetype freebsd-doc @@ -274,6 +275,11 @@ at URI, which may be a file:// URI pointing the package's tree." "http://directory.fsf.org/wiki/License:EPLv1.0" "https://www.gnu.org/licenses/license-list#EPL")) +(define epl2.0 + (license "EPL 2.0" + "https://www.eclipse.org/legal/epl-2.0/" + "https://www.gnu.org/licenses/license-list#EPL2")) + (define expat (license "Expat" "http://directory.fsf.org/wiki/License:Expat" -- cgit v1.2.3 From 0bd1498fc40820be35125cc0a62482d015b58e9b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 8 Mar 2019 23:13:56 +0100 Subject: upstream: Correctly report failure to update Git checkouts. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . Reported by Gábor Boskovits . * guix/upstream.scm (package-update/url-fetch): New procedure, with code formerly in 'package-update'. (%method-updates): New variable. (package-update): Check the method to download PACKAGE's source, and look up a corresponding update method in %METHOD-UPDATES, and raise an error if none was found. --- guix/upstream.scm | 53 ++++++++++++++++++++++++++++++++++++++++------------- 1 file changed, 40 insertions(+), 13 deletions(-) (limited to 'guix') diff --git a/guix/upstream.scm b/guix/upstream.scm index 9163478099..55683dd9b7 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2015 Alex Kost ;;; Copyright © 2019 Ricardo Wurmus ;;; @@ -23,7 +23,7 @@ #:use-module (guix utils) #:use-module (guix discovery) #:use-module ((guix download) - #:select (download-to-store)) + #:select (download-to-store url-fetch)) #:use-module (guix gnupg) #:use-module (guix packages) #:use-module (guix ui) @@ -37,6 +37,8 @@ #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:export (upstream-source @@ -340,17 +342,13 @@ values: the item from LST1 and the item from LST2 that match PRED." (() (values #f #f))))) -(define* (package-update store package updaters - #:key (key-download 'interactive)) - "Return the new version, the file name of the new version tarball, and input -changes for PACKAGE; return #f (three values) when PACKAGE is up-to-date. -KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed -values: 'always', 'never', and 'interactive' (default)." - (match (package-latest-release* package updaters) +(define* (package-update/url-fetch store package source + #:key key-download) + "Return the version, tarball, and input changes needed to update PACKAGE to +SOURCE, an ." + (match source (($ _ version urls signature-urls changes) - (let*-values (((name) - (package-name package)) - ((archive-type) + (let*-values (((archive-type) (match (and=> (package-source package) origin-uri) ((? string? uri) (let ((type (file-extension (basename uri)))) @@ -373,7 +371,36 @@ values: 'always', 'never', and 'interactive' (default)." (or signature-urls (circular-list #f))))) (let ((tarball (download-tarball store url signature-url #:key-download key-download))) - (values version tarball changes)))) + (values version tarball changes)))))) + +(define %method-updates + ;; Mapping of origin methods to source update procedures. + `((,url-fetch . ,package-update/url-fetch))) + +(define* (package-update store package updaters + #:key (key-download 'interactive)) + "Return the new version, the file name of the new version tarball, and input +changes for PACKAGE; return #f (three values) when PACKAGE is up-to-date. +KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed +values: 'always', 'never', and 'interactive' (default)." + (match (package-latest-release* package updaters) + ((? upstream-source? source) + (let ((method (match (package-source package) + ((? origin? origin) + (origin-method origin)) + (_ + #f)))) + (match (assq method %method-updates) + (#f + (raise (condition (&message + (message (format #f (G_ "cannot download for \ +this method: ~s") + method))) + (&error-location + (location (package-location package)))))) + ((_ . update) + (update store package source + #:key-download key-download))))) (#f (values #f #f #f)))) -- cgit v1.2.3