From 72357e2170e88f73c11ff089f87a744cee8606ec Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 8 Jun 2020 21:39:55 +0200 Subject: git: 'commit-difference' really excludes the ancestors of #:excluded. * guix/git.scm (commit-difference): Initialize VISITED to the closure of OLD and EXCLUDED, as written in the docstring. * tests/git.scm ("commit-difference, excluded commits"): Adjust accordingly. --- guix/git.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/git.scm b/guix/git.scm index 1671f57d9f..0d8e617cc9 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -416,7 +416,9 @@ Essentially, this computes the set difference between the closure of NEW and that of OLD." (let loop ((commits (list new)) (result '()) - (visited (commit-closure old (list->setq excluded)))) + (visited (fold commit-closure + (setq) + (cons old excluded)))) (match commits (() (reverse result)) -- cgit v1.2.3 From eef859e8538a74f7dd743bf294f9c32a62a52381 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 8 Jun 2020 22:25:59 +0200 Subject: git-authenticate: 'commit-authorized-keys' properly handles orphan commits. Previously it would trigger a wrong-number-of-arguments error for 'lset-intersection'. * guix/git-authenticate.scm (commit-authorized-keys): Add case for when 'commit-parents' returns the empty list. --- guix/git-authenticate.scm | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/git-authenticate.scm b/guix/git-authenticate.scm index 00d22ef479..c333717136 100644 --- a/guix/git-authenticate.scm +++ b/guix/git-authenticate.scm @@ -184,8 +184,11 @@ to remove '.guix-authorizations' file") default-authorizations) (throw key error))))) - (apply lset-intersection bytevector=? - (map commit-authorizations (commit-parents commit)))) + (match (commit-parents commit) + (() default-authorizations) + (parents + (apply lset-intersection bytevector=? + (map commit-authorizations parents))))) (define* (authenticate-commit repository commit keyring #:key (default-authorizations '())) -- cgit v1.2.3 From 7a45b5d5ba892e82fba836df94a6c6889e08c959 Mon Sep 17 00:00:00 2001 From: Lars-Dominik Braun Date: Fri, 5 Jun 2020 10:38:32 +0200 Subject: store: Use buffered I/O for all protocol writes MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/store.scm (run-gc) Use buffered output port. (export-path) Same. (add-file-tree-to-store) Same. (set-build-options): Same. Add explicit flush. Signed-off-by: Ludovic Courtès --- guix/store.scm | 70 ++++++++++++++++++++++++++++++++-------------------------- 1 file changed, 39 insertions(+), 31 deletions(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index 014d08aaec..9b3879b4a7 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2018 Jan Nieuwenhuizen ;;; Copyright © 2019, 2020 Mathieu Othacehe ;;; Copyright © 2020 Florian Pelz +;;; Copyright © 2020 Lars-Dominik Braun ;;; ;;; This file is part of GNU Guix. ;;; @@ -821,8 +822,8 @@ encoding conversion errors." (locale (false-if-exception (setlocale LC_ALL)))) ;; Must be called after `open-connection'. - (define socket - (store-connection-socket server)) + (define buffered + (store-connection-output-port server)) (unless (unspecified? use-build-hook?) (warn-about-deprecation #:use-build-hook? #f @@ -831,9 +832,9 @@ encoding conversion errors." (let-syntax ((send (syntax-rules () ((_ (type option) ...) (begin - (write-arg type option socket) + (write-arg type option buffered) ...))))) - (write-int (operation-id set-options) socket) + (write-int (operation-id set-options) buffered) (send (boolean keep-failed?) (boolean keep-going?) (boolean fallback?) (integer verbosity)) (when (< (store-connection-minor-version server) #x61) @@ -896,6 +897,7 @@ encoding conversion errors." `(("locale" . ,locale)) '())))) (send (string-pairs pairs)))) + (write-buffered-output server) (let loop ((done? (process-stderr server))) (or done? (process-stderr server))))) @@ -1108,13 +1110,14 @@ path." ;; We don't use the 'operation' macro so we can pass SELECT? to ;; 'write-file'. (record-operation 'add-to-store) - (let ((port (store-connection-socket server))) - (write-int (operation-id add-to-store) port) - (write-string basename port) - (write-int 1 port) ;obsolete, must be #t - (write-int (if recursive? 1 0) port) - (write-string hash-algo port) - (write-file file-name port #:select? select?) + (let ((port (store-connection-socket server)) + (buffered (store-connection-output-port server))) + (write-int (operation-id add-to-store) buffered) + (write-string basename buffered) + (write-int 1 buffered) ;obsolete, must be #t + (write-int (if recursive? 1 0) buffered) + (write-string hash-algo buffered) + (write-file file-name buffered #:select? select?) (write-buffered-output server) (let loop ((done? (process-stderr server))) (or done? (loop (process-stderr server)))) @@ -1220,13 +1223,14 @@ an arbitrary directory layout in the store without creating a derivation." ;; We don't use the 'operation' macro so we can use 'write-file-tree' ;; instead of 'write-file'. (record-operation 'add-to-store/tree) - (let ((port (store-connection-socket server))) - (write-int (operation-id add-to-store) port) - (write-string basename port) - (write-int 1 port) ;obsolete, must be #t - (write-int (if recursive? 1 0) port) - (write-string hash-algo port) - (write-file-tree basename port + (let ((port (store-connection-socket server)) + (buffered (store-connection-output-port server))) + (write-int (operation-id add-to-store) buffered) + (write-string basename buffered) + (write-int 1 buffered) ;obsolete, must be #t + (write-int (if recursive? 1 0) buffered) + (write-string hash-algo buffered) + (write-file-tree basename buffered #:file-type+size file-type+size #:file-port file-port #:symlink-target symlink-target @@ -1644,17 +1648,19 @@ the list of store paths to delete. IGNORE-LIVENESS? should always be #f. MIN-FREED is the minimum amount of disk space to be freed, in bytes, before the GC can stop. Return the list of store paths delete, and the number of bytes freed." - (let ((s (store-connection-socket server))) - (write-int (operation-id collect-garbage) s) - (write-int action s) - (write-store-path-list to-delete s) - (write-arg boolean #f s) ; ignore-liveness? - (write-long-long min-freed s) - (write-int 0 s) ; obsolete + (let ((s (store-connection-socket server)) + (buffered (store-connection-output-port server))) + (write-int (operation-id collect-garbage) buffered) + (write-int action buffered) + (write-store-path-list to-delete buffered) + (write-arg boolean #f buffered) ; ignore-liveness? + (write-long-long min-freed buffered) + (write-int 0 buffered) ; obsolete (when (>= (store-connection-minor-version server) 5) ;; Obsolete `use-atime' and `max-atime' parameters. - (write-int 0 s) - (write-int 0 s)) + (write-int 0 buffered) + (write-int 0 buffered)) + (write-buffered-output server) ;; Loop until the server is done sending error output. (let loop ((done? (process-stderr server))) @@ -1711,10 +1717,12 @@ is raised if the set of paths read from PORT is not signed (as per (define* (export-path server path port #:key (sign? #t)) "Export PATH to PORT. When SIGN? is true, sign it." - (let ((s (store-connection-socket server))) - (write-int (operation-id export-path) s) - (write-store-path path s) - (write-arg boolean sign? s) + (let ((s (store-connection-socket server)) + (buffered (store-connection-output-port server))) + (write-int (operation-id export-path) buffered) + (write-store-path path buffered) + (write-arg boolean sign? buffered) + (write-buffered-output server) (let loop ((done? (process-stderr server port))) (or done? (loop (process-stderr server port)))) (= 1 (read-int s)))) -- cgit v1.2.3 From 2e08394b3c64ad77cebb94f54677130e4fdaf9e9 Mon Sep 17 00:00:00 2001 From: Marius Bakke Date: Mon, 8 Jun 2020 21:13:46 +0200 Subject: import: stackage: Fix typo. * guix/import/stackage.scm (latest-lts-release): Fix spelling of "included". --- guix/import/stackage.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm index 14150201b5..9572f8c26d 100644 --- a/guix/import/stackage.scm +++ b/guix/import/stackage.scm @@ -122,7 +122,7 @@ included in the Stackage LTS release." (let ((pkgs-info (mlambda () (lts-info-packages (stackage-lts-info-fetch))))) (lambda* (package) "Return an for the latest Stackage LTS release of -PACKAGE or #f it the package is not inlucded in the Stackage LTS release." +PACKAGE or #f it the package is not included in the Stackage LTS release." (let* ((hackage-name (guix-package->hackage-name package)) (version (lts-package-version (pkgs-info) hackage-name)) (name-version (hackage-name-version hackage-name version))) -- cgit v1.2.3 From 35b00d4caa798ca03a0d4c01ca02c656590ccaa5 Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Tue, 9 Jun 2020 22:29:38 +0200 Subject: import: stackage: Fix typo. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/import/stackage.scm (latest-lts-release): Fix spelling of ‘if’. --- guix/import/stackage.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm index 9572f8c26d..e04073d193 100644 --- a/guix/import/stackage.scm +++ b/guix/import/stackage.scm @@ -122,7 +122,7 @@ included in the Stackage LTS release." (let ((pkgs-info (mlambda () (lts-info-packages (stackage-lts-info-fetch))))) (lambda* (package) "Return an for the latest Stackage LTS release of -PACKAGE or #f it the package is not included in the Stackage LTS release." +PACKAGE or #f if the package is not included in the Stackage LTS release." (let* ((hackage-name (guix-package->hackage-name package)) (version (lts-package-version (pkgs-info) hackage-name)) (name-version (hackage-name-version hackage-name version))) -- cgit v1.2.3 From 3cd92a855e8f6768a4470cd5522749a39d5f9047 Mon Sep 17 00:00:00 2001 From: Caleb Ristvedt Date: Mon, 1 Jun 2020 18:50:07 -0500 Subject: database: work around guile-sqlite3 bug preventing statement reset MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit guile-sqlite3 provides statement caching, making it unnecessary for sqlite to keep re-preparing statements that are frequently used. Unfortunately it doesn't quite emulate the semantics of sqlite_finalize properly, because it doesn't cause a commit if the statement being finalized is the last "active" statement (see https://notabug.org/guile-sqlite3/guile-sqlite3/issues/12). We work around this by wrapping sqlite-finalize with our own version that ensures sqlite-reset is called, which does The Right Thing™. * guix/store/database.scm (sqlite-finalize): new procedure that shadows the sqlite-finalize from (sqlite3). --- guix/store/database.scm | 11 +++++++++++ 1 file changed, 11 insertions(+) (limited to 'guix') diff --git a/guix/store/database.scm b/guix/store/database.scm index ef52036ede..ae7e96df2f 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -130,6 +130,17 @@ transaction after it finishes." If FILE doesn't exist, create it and initialize it as a new database." (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 (last-insert-row-id db) ;; XXX: (sqlite3) currently lacks bindings for 'sqlite3_last_insert_rowid'. ;; Work around that. -- cgit v1.2.3 From 5d6e2255286e591def122ec2f4a3cbda497fea21 Mon Sep 17 00:00:00 2001 From: Caleb Ristvedt Date: Mon, 1 Jun 2020 19:21:43 -0500 Subject: database: rewrite query procedures in terms of with-statement. Most of our queries would fail to finalize their statements properly if sqlite returned an error during their execution. This resolves that, and also makes them somewhat more concise as a side-effect. This also makes some small changes to improve certain queries where behavior was strange or overly verbose. * guix/store/database.scm (call-with-statement): new procedure. (with-statement): new macro. (last-insert-row-id, path-id, update-or-insert, add-references): rewrite to use with-statement. (update-or-insert): factor last-insert-row-id out of the end of both branches. (add-references): remove pointless last-insert-row-id call. * .dir-locals.el (with-statement): add indenting information. --- .dir-locals.el | 1 + guix/store/database.scm | 53 +++++++++++++++++++++++++++---------------------- 2 files changed, 30 insertions(+), 24 deletions(-) (limited to 'guix') diff --git a/.dir-locals.el b/.dir-locals.el index dc8bc0e437..77c12f9411 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -89,6 +89,7 @@ (eval . (put 'with-database 'scheme-indent-function 2)) (eval . (put 'call-with-transaction 'scheme-indent-function 2)) + (eval . (put 'with-statement 'scheme-indent-function 3)) (eval . (put 'call-with-container 'scheme-indent-function 1)) (eval . (put 'container-excursion 'scheme-indent-function 1)) diff --git a/guix/store/database.scm b/guix/store/database.scm index ae7e96df2f..e74c4ba991 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -141,14 +141,26 @@ If FILE doesn't exist, create it and initialize it as a new database." (sqlite-reset stmt) ((@ (sqlite3) sqlite-finalize) stmt)) +(define (call-with-statement db sql proc) + (let ((stmt (sqlite-prepare db sql #:cache? #t))) + (dynamic-wind + (const #t) + (lambda () + (proc stmt)) + (lambda () + (sqlite-finalize stmt))))) + +(define-syntax-rule (with-statement db sql stmt exp ...) + "Run EXP... with STMT bound to a prepared statement corresponding to the sql +string SQL for DB." + (call-with-statement db sql + (lambda (stmt) exp ...))) + (define (last-insert-row-id db) ;; XXX: (sqlite3) currently lacks bindings for 'sqlite3_last_insert_rowid'. ;; Work around that. - (let* ((stmt (sqlite-prepare db "SELECT last_insert_rowid();" - #:cache? #t)) - (result (sqlite-fold cons '() stmt))) - (sqlite-finalize stmt) - (match result + (with-statement db "SELECT last_insert_rowid();" stmt + (match (sqlite-fold cons '() stmt) ((#(id)) id) (_ #f)))) @@ -158,13 +170,11 @@ If FILE doesn't exist, create it and initialize it as a new database." (define* (path-id db path) "If PATH exists in the 'ValidPaths' table, return its numerical identifier. Otherwise, return #f." - (let ((stmt (sqlite-prepare db path-id-sql #:cache? #t))) + (with-statement db path-id-sql stmt (sqlite-bind-arguments stmt #:path path) - (let ((result (sqlite-fold cons '() stmt))) - (sqlite-finalize stmt) - (match result - ((#(id) . _) id) - (_ #f))))) + (match (sqlite-fold cons '() stmt) + ((#(id) . _) id) + (_ #f)))) (define update-sql "UPDATE ValidPaths SET hash = :hash, registrationTime = :time, deriver = @@ -181,20 +191,17 @@ 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." (let ((id (path-id db path))) (if id - (let ((stmt (sqlite-prepare db update-sql #:cache? #t))) + (with-statement db update-sql stmt (sqlite-bind-arguments stmt #:id id #:deriver deriver #:hash hash #:size nar-size #:time time) - (sqlite-fold cons '() stmt) - (sqlite-finalize stmt) - (last-insert-row-id db)) - (let ((stmt (sqlite-prepare db insert-sql #:cache? #t))) + (sqlite-fold cons '() stmt)) + (with-statement db insert-sql stmt (sqlite-bind-arguments stmt #:path path #:deriver deriver #:hash hash #:size nar-size #:time time) - (sqlite-fold cons '() stmt) ;execute it - (sqlite-finalize stmt) - (last-insert-row-id db))))) + (sqlite-fold cons '() stmt))) + (last-insert-row-id db))) (define add-reference-sql "INSERT OR REPLACE INTO Refs (referrer, reference) VALUES (:referrer, :reference);") @@ -202,15 +209,13 @@ of course. Returns the row id of the row that was modified or inserted." (define (add-references db referrer references) "REFERRER is the id of the referring store item, REFERENCES is a list ids of items referred to." - (let ((stmt (sqlite-prepare db add-reference-sql #:cache? #t))) + (with-statement db add-reference-sql stmt (for-each (lambda (reference) (sqlite-reset stmt) (sqlite-bind-arguments stmt #:referrer referrer #:reference reference) - (sqlite-fold cons '() stmt) ;execute it - (last-insert-row-id db)) - references) - (sqlite-finalize stmt))) + (sqlite-fold cons '() stmt)) + references))) (define* (sqlite-register db #:key path (references '()) deriver hash nar-size time) -- cgit v1.2.3 From 37545de4a3bf59611c184b31506fe9a16abe4c8b Mon Sep 17 00:00:00 2001 From: Caleb Ristvedt Date: Mon, 1 Jun 2020 21:43:14 -0500 Subject: database: ensure update-or-insert is run within a transaction update-or-insert can break if an insert occurs between when it decides whether to update or insert and when it actually performs that operation. Putting the check and the update/insert operation in the same transaction ensures that the update/insert will only succeed if no other write has occurred in the middle. * guix/store/database.scm (call-with-savepoint): new procedure. (update-or-insert): use call-with-savepoint to ensure the read and the insert/update occur within the same transaction. --- .dir-locals.el | 1 + guix/store/database.scm | 68 +++++++++++++++++++++++++++++++++++++++---------- 2 files changed, 56 insertions(+), 13 deletions(-) (limited to 'guix') diff --git a/.dir-locals.el b/.dir-locals.el index 77c12f9411..d9c81b2a48 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -90,6 +90,7 @@ (eval . (put 'with-database 'scheme-indent-function 2)) (eval . (put 'call-with-transaction 'scheme-indent-function 2)) (eval . (put 'with-statement 'scheme-indent-function 3)) + (eval . (put 'call-with-savepoint 'scheme-indent-function 1)) (eval . (put 'call-with-container 'scheme-indent-function 1)) (eval . (put 'container-excursion 'scheme-indent-function 1)) diff --git a/guix/store/database.scm b/guix/store/database.scm index e74c4ba991..3193dcf23c 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -120,6 +120,26 @@ transaction after it finishes." (begin (sqlite-exec db "rollback;") (throw 'sqlite-error who error description)))))) +(define* (call-with-savepoint db proc + #:optional (savepoint-name "SomeSavepoint")) + "Call PROC after creating a savepoint named SAVEPOINT-NAME. If PROC exits +abnormally, rollback to that savepoint. In all cases, remove the savepoint +prior to returning." + (define (exec sql) + (with-statement db sql stmt + (sqlite-fold cons '() stmt))) + + (dynamic-wind + (lambda () + (exec (string-append "SAVEPOINT " savepoint-name ";"))) + (lambda () + (catch #t + proc + (lambda args + (exec (string-append "ROLLBACK TO " savepoint-name ";")) + (apply throw args)))) + (lambda () + (exec (string-append "RELEASE " savepoint-name ";"))))) (define %default-database-file ;; Default location of the store database. @@ -189,19 +209,41 @@ VALUES (:path, :hash, :time, :deriver, :size)") 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." - (let ((id (path-id db path))) - (if id - (with-statement db update-sql stmt - (sqlite-bind-arguments stmt #:id id - #:deriver deriver - #:hash hash #:size nar-size #:time time) - (sqlite-fold cons '() stmt)) - (with-statement db insert-sql stmt - (sqlite-bind-arguments stmt - #:path path #:deriver deriver - #:hash hash #:size nar-size #:time time) - (sqlite-fold cons '() stmt))) - (last-insert-row-id db))) + + ;; 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 + ;; whether it's already registered and when we register it, resulting in + ;; duplicate paths (which, due to a 'unique' constraint, would cause an + ;; exception to be thrown). With the default journaling mode this will + ;; prevent writes from occurring during that sensitive time, but with WAL + ;; mode it will instead arrange to return SQLITE_BUSY when a write occurs + ;; between the start of a read transaction and its upgrading to a write + ;; transaction (see https://sqlite.org/rescode.html#busy_snapshot). + ;; Experimentally, it seems this SQLITE_BUSY will ignore a busy_timeout and + ;; immediately return (makes sense, since waiting won't change anything). + + ;; Note that when that kind of SQLITE_BUSY error is returned, it will keep + ;; being returned every time we try to upgrade the same outermost + ;; transaction to a write transaction. So when retrying, we have to restart + ;; the *outermost* write transaction. We can't inherently tell whether + ;; we're the outermost write transaction, so we leave the retry-handling to + ;; the caller. + (call-with-savepoint db + (lambda () + (let ((id (path-id db path))) + (if id + (with-statement db update-sql stmt + (sqlite-bind-arguments stmt #:id id + #:deriver deriver + #:hash hash #:size nar-size #:time time) + (sqlite-fold cons '() stmt)) + (with-statement db insert-sql stmt + (sqlite-bind-arguments stmt + #:path path #:deriver deriver + #:hash hash #:size nar-size #:time time) + (sqlite-fold cons '() stmt))) + (last-insert-row-id db))))) (define add-reference-sql "INSERT OR REPLACE INTO Refs (referrer, reference) VALUES (:referrer, :reference);") -- cgit v1.2.3 From 8971f626f2e69987bea729307adb93a0be243234 Mon Sep 17 00:00:00 2001 From: Caleb Ristvedt Date: Mon, 1 Jun 2020 22:15:21 -0500 Subject: database: separate transaction-handling and retry-handling. Previously call-with-transaction would both retry when SQLITE_BUSY errors were thrown and do what its name suggested (start and rollback/commit a transaction). This changes it to do only what its name implies, which simplifies its implementation. Retrying is provided by the new call-with-SQLITE_BUSY-retrying procedure. * guix/store/database.scm (call-with-transaction): no longer restarts, new #:restartable? argument controls whether "begin" or "begin immediate" is used. (call-with-SQLITE_BUSY-retrying, call-with-retrying-transaction, call-with-retrying-savepoint): new procedures. (register-items): use call-with-retrying-transaction to preserve old behavior. * .dir-locals.el (call-with-retrying-transaction, call-with-retrying-savepoint): add indentation information. --- .dir-locals.el | 2 ++ guix/store/database.scm | 69 +++++++++++++++++++++++++++++++++++-------------- 2 files changed, 51 insertions(+), 20 deletions(-) (limited to 'guix') diff --git a/.dir-locals.el b/.dir-locals.el index d9c81b2a48..b88ec7a795 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -90,7 +90,9 @@ (eval . (put 'with-database 'scheme-indent-function 2)) (eval . (put 'call-with-transaction 'scheme-indent-function 2)) (eval . (put 'with-statement 'scheme-indent-function 3)) + (eval . (put 'call-with-retrying-transaction 'scheme-indent-function 2)) (eval . (put 'call-with-savepoint 'scheme-indent-function 1)) + (eval . (put 'call-with-retrying-savepoint 'scheme-indent-function 1)) (eval . (put 'call-with-container 'scheme-indent-function 1)) (eval . (put 'container-excursion 'scheme-indent-function 1)) diff --git a/guix/store/database.scm b/guix/store/database.scm index 3193dcf23c..ad9ca68efe 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -99,27 +99,44 @@ create it and initialize it as a new database." ;; 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." +(define (call-with-SQLITE_BUSY-retrying thunk) + "Call THUNK, retrying as long as it exits abnormally due to SQLITE_BUSY +errors." (catch 'sqlite-error + thunk + (lambda (key who code errmsg) + (if (= code SQLITE_BUSY) + (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. +RESTARTABLE? may be set to a non-#f value when it is safe to run PROC multiple +times. This may reduce contention for the database somewhat." + (define (exec sql) + (with-statement db sql stmt + (sqlite-fold cons '() stmt))) + ;; We might 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!) might have to be executed again for + ;; every retry. + (exec (if restartable? "begin;" "begin immediate;")) + (catch #t (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)))))) + (let-values ((result (proc))) + (exec "commit;") + (apply values result))) + (lambda args + ;; The roll back may or may not have occurred automatically when the + ;; error was generated. If it has occurred, this does nothing but signal + ;; an error. If it hasn't occurred, this needs to be done. + (false-if-exception (exec "rollback;")) + (apply throw args)))) + (define* (call-with-savepoint db proc #:optional (savepoint-name "SomeSavepoint")) "Call PROC after creating a savepoint named SAVEPOINT-NAME. If PROC exits @@ -141,6 +158,18 @@ prior to returning." (lambda () (exec (string-append "RELEASE " savepoint-name ";"))))) +(define* (call-with-retrying-transaction db proc #:key restartable?) + (call-with-SQLITE_BUSY-retrying + (lambda () + (call-with-transaction db proc #:restartable? restartable?)))) + +(define* (call-with-retrying-savepoint db proc + #:optional (savepoint-name + "SomeSavepoint")) + (call-with-SQLITE_BUSY-retrying + (lambda () + (call-with-savepoint db proc savepoint-name)))) + (define %default-database-file ;; Default location of the store database. (string-append %store-database-directory "/db.sqlite")) @@ -412,7 +441,7 @@ Write a progress report to LOG-PORT." (mkdir-p db-dir) (parameterize ((sql-schema schema)) (with-database (string-append db-dir "/db.sqlite") db - (call-with-transaction db + (call-with-retrying-transaction db (lambda () (let* ((prefix (format #f "registering ~a items" (length items))) (progress (progress-reporter/bar (length items) -- cgit v1.2.3 From 03a70e4c190420e87c0b535285caf8f77260d4ff Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 11 Jun 2020 18:24:59 +0200 Subject: packages: 'package-grafts' returns grafts for all the relevant outputs. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . Reported by Jakub Kądziołka . * guix/packages.scm (input-graft): Add 'output' parameter and honor it. Add OUTPUT to the cache key. (input-cross-graft): Likewise. (fold-bag-dependencies): Operate on inputs instead of nodes. Turn VISITED into a vhash instead of a set. Pass PROC HEAD and OUTPUT instead of just HEAD. (bag-grafts): Adjust accordingly. * tests/packages.scm ("package-grafts, dependency on several outputs"): New test. --- guix/packages.scm | 81 +++++++++++++++++++++++++----------------------------- tests/packages.scm | 24 ++++++++++++++++ 2 files changed, 62 insertions(+), 43 deletions(-) (limited to 'guix') diff --git a/guix/packages.scm b/guix/packages.scm index 0ccd31a7a9..1e0ec41b76 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -1194,39 +1194,39 @@ and return it." (make-weak-key-hash-table 200)) (define (input-graft store system) - "Return a procedure that, given a package with a graft, returns a graft, and -#f otherwise." - (match-lambda - ((? package? package) + "Return a procedure that, given a package with a replacement and an output name, +returns a graft, and #f otherwise." + (match-lambda* + (((? package? package) output) (let ((replacement (package-replacement package))) (and replacement - (cached (=> %graft-cache) package system + (cached (=> %graft-cache) package (cons output system) (let ((orig (package-derivation store package system #:graft? #f)) (new (package-derivation store replacement system #:graft? #t))) (graft (origin orig) - (replacement new))))))) - (x - #f))) + (origin-output output) + (replacement new) + (replacement-output output))))))))) (define (input-cross-graft store target system) "Same as 'input-graft', but for cross-compilation inputs." - (match-lambda - ((? package? package) - (let ((replacement (package-replacement package))) - (and replacement - (let ((orig (package-cross-derivation store package target system - #:graft? #f)) - (new (package-cross-derivation store replacement - target system - #:graft? #t))) - (graft - (origin orig) - (replacement new)))))) - (_ - #f))) + (match-lambda* + (((? package? package) output) + (let ((replacement (package-replacement package))) + (and replacement + (let ((orig (package-cross-derivation store package target system + #:graft? #f)) + (new (package-cross-derivation store replacement + target system + #:graft? #t))) + (graft + (origin orig) + (origin-output output) + (replacement new) + (replacement-output output)))))))) (define* (fold-bag-dependencies proc seed bag #:key (native? #t)) @@ -1243,26 +1243,21 @@ dependencies; otherwise, restrict to target dependencies." (bag-host-inputs bag)))) bag-host-inputs)) - (define nodes - (match (bag-direct-inputs* bag) - (((labels things _ ...) ...) - things))) - - (let loop ((nodes nodes) + (let loop ((inputs (bag-direct-inputs* bag)) (result seed) - (visited (setq))) - (match nodes + (visited vlist-null)) + (match inputs (() result) - (((? package? head) . tail) - (if (set-contains? visited head) - (loop tail result visited) - (let ((inputs (bag-direct-inputs* (package->bag head)))) - (loop (match inputs - (((labels things _ ...) ...) - (append things tail))) - (proc head result) - (set-insert head visited))))) + (((label (? package? head) . rest) . tail) + (let ((output (match rest (() "out") ((output) output))) + (outputs (vhash-foldq* cons '() head visited))) + (if (member output outputs) + (loop tail result visited) + (let ((inputs (bag-direct-inputs* (package->bag head)))) + (loop (append inputs tail) + (proc head output result) + (vhash-consq head output visited)))))) ((head . tail) (loop tail result visited))))) @@ -1279,8 +1274,8 @@ to (see 'graft-derivation'.)" (let ((->graft (input-graft store system))) (parameterize ((%current-system system) (%current-target-system #f)) - (fold-bag-dependencies (lambda (package grafts) - (match (->graft package) + (fold-bag-dependencies (lambda (package output grafts) + (match (->graft package output) (#f grafts) (graft (cons graft grafts)))) '() @@ -1291,8 +1286,8 @@ to (see 'graft-derivation'.)" (let ((->graft (input-cross-graft store target system))) (parameterize ((%current-system system) (%current-target-system target)) - (fold-bag-dependencies (lambda (package grafts) - (match (->graft package) + (fold-bag-dependencies (lambda (package output grafts) + (match (->graft package output) (#f grafts) (graft (cons graft grafts)))) '() diff --git a/tests/packages.scm b/tests/packages.scm index 72e87dbfb7..c7b6f669b5 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -900,6 +900,30 @@ (replacement #f)))) (replacement (package-derivation %store new))))))) +(test-assert "package-grafts, dependency on several outputs" + ;; Make sure we get one graft per output; see . + (letrec* ((p0 (dummy-package "p0" + (version "1.0") + (replacement p0*) + (arguments '(#:implicit-inputs? #f)) + (outputs '("out" "lib")))) + (p0* (package (inherit p0) (version "1.1"))) + (p1 (dummy-package "p1" + (arguments '(#:implicit-inputs? #f)) + (inputs `(("p0" ,p0) + ("p0:lib" ,p0 "lib")))))) + (lset= equal? (pk (package-grafts %store p1)) + (list (graft + (origin (package-derivation %store p0)) + (origin-output "out") + (replacement (package-derivation %store p0*)) + (replacement-output "out")) + (graft + (origin (package-derivation %store p0)) + (origin-output "lib") + (replacement (package-derivation %store p0*)) + (replacement-output "lib")))))) + (test-assert "replacement also grafted" ;; We build a DAG as below, where dotted arrows represent replacements and ;; solid arrows represent dependencies: -- cgit v1.2.3