summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2020-06-18 11:51:44 +0200
committerLudovic Courtès <ludo@gnu.org>2020-06-18 14:48:17 +0200
commit97a46055ca9f72986740c26a5406b5138176ca61 (patch)
tree24a14640b53264a24151b6c9e895d4f51d4ce078 /guix
parentf9a0fc9dbbfcdf28c77fd9199e3f1a73d901199c (diff)
database: 'register-items' takes an open database.
* guix/store/database.scm (store-database-directory) (store-database-file): New procedures. (call-with-database): Add call to 'mkdir-p'. (register-items): Add 'db' parameter and remove #:state-directory and #:schema. (register-path): Use 'store-database-file' and 'with-database', and parameterize SQL-SCHEMA. * gnu/build/image.scm (register-closure): Likewise. * gnu/build/vm.scm (register-closure): Likewise. * guix/scripts/pack.scm (store-database)[build]: Likewise.
Diffstat (limited to 'guix')
-rw-r--r--guix/scripts/pack.scm15
-rw-r--r--guix/store/database.scm98
2 files changed, 63 insertions, 50 deletions
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 55fb3e8df3..e0f9cc1a12 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -146,13 +146,16 @@ dependencies are registered."
(define (read-closure closure)
(call-with-input-file closure read-reference-graph))
+ (define db-file
+ (store-database-file #:state-directory #$output))
+
+ (sql-schema #$schema)
(let ((items (append-map read-closure '#$labels)))
- (register-items items
- #:state-directory #$output
- #:deduplicate? #f
- #:reset-timestamps? #f
- #:registration-time %epoch
- #:schema #$schema))))))
+ (with-database db-file db
+ (register-items db items
+ #:deduplicate? #f
+ #:reset-timestamps? #f
+ #:registration-time %epoch)))))))
(computed-file "store-database" build
#:options `(#:references-graphs ,(zip labels items))))
diff --git a/guix/store/database.scm b/guix/store/database.scm
index ad9ca68efe..a38e4d7e52 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -37,6 +37,7 @@
#:use-module (system foreign)
#:export (sql-schema
%default-database-file
+ store-database-file
with-database
path-id
sqlite-register
@@ -65,6 +66,28 @@
(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."
+ ;; Priority for options: first what is given, then environment variables,
+ ;; then defaults. %state-directory, %store-directory, and
+ ;; %store-database-directory already handle the "environment variables /
+ ;; defaults" question, so we only need to choose between what is given and
+ ;; those.
+ (cond (state-directory
+ (string-append state-directory "/db"))
+ (prefix
+ (string-append prefix %localstatedir "/guix/db"))
+ (else
+ %store-database-directory)))
+
+(define* (store-database-file #:key prefix state-directory)
+ "Return the store database file name, taking PREFIX and STATE-DIRECTORY into
+account when provided."
+ (string-append (store-database-directory #:prefix prefix
+ #:state-directory state-directory)
+ "/db.sqlite"))
+
(define (initialize-database db)
"Initializing DB, an empty database, by creating all the tables and indexes
as specified by SQL-SCHEMA."
@@ -77,7 +100,10 @@ as specified by SQL-SCHEMA."
(define (call-with-database file proc)
"Pass PROC a database record corresponding to FILE. If FILE doesn't exist,
create it and initialize it as a new database."
- (let ((new? (not (file-exists? file)))
+ (let ((new? (and (not (file-exists? file))
+ (begin
+ (mkdir-p (dirname file))
+ #t)))
(db (sqlite-open file)))
;; Turn DB in "write-ahead log" mode, which should avoid SQLITE_LOCKED
;; errors when we have several readers: <https://www.sqlite.org/wal.html>.
@@ -361,45 +387,32 @@ Return #t on success.
Use with care as it directly modifies the store! This is primarily meant to
be used internally by the daemon's build hook."
- (register-items (list (store-info path deriver references))
- #:prefix prefix #:state-directory state-directory
- #:deduplicate? deduplicate?
- #:reset-timestamps? reset-timestamps?
- #:schema schema
- #:log-port (%make-void-port "w")))
+ (define db-file
+ (store-database-file #:prefix prefix
+ #:state-directory state-directory))
+
+ (parameterize ((sql-schema schema))
+ (with-database db-file db
+ (register-items db (list (store-info path deriver references))
+ #:prefix prefix
+ #:deduplicate? deduplicate?
+ #:reset-timestamps? reset-timestamps?
+ #:log-port (%make-void-port "w")))))
(define %epoch
;; When it all began.
(make-time time-utc 0 1))
-(define* (register-items items
- #:key prefix state-directory
+(define* (register-items db items
+ #:key prefix
(deduplicate? #t)
(reset-timestamps? #t)
registration-time
- (schema (sql-schema))
(log-port (current-error-port)))
"Register all of ITEMS, a list of <store-info> records as returned by
-'read-reference-graph', in the database under PREFIX/STATE-DIRECTORY. ITEMS
-must be in topological order (with leaves first.) If the database is
-initially empty, apply SCHEMA to initialize it. REGISTRATION-TIME must be the
-registration time to be recorded in the database; #f means \"now\".
-Write a progress report to LOG-PORT."
-
- ;; Priority for options: first what is given, then environment variables,
- ;; then defaults. %state-directory, %store-directory, and
- ;; %store-database-directory already handle the "environment variables /
- ;; defaults" question, so we only need to choose between what is given and
- ;; those.
-
- (define db-dir
- (cond (state-directory
- (string-append state-directory "/db"))
- (prefix
- (string-append prefix %localstatedir "/guix/db"))
- (else
- %store-database-directory)))
-
+'read-reference-graph', in DB. ITEMS must be in topological order (with
+leaves first.) REGISTRATION-TIME must be the registration time to be recorded
+in the database; #f means \"now\". Write a progress report to LOG-PORT."
(define store-dir
(if prefix
(string-append prefix %storedir)
@@ -438,17 +451,14 @@ Write a progress report to LOG-PORT."
(when deduplicate?
(deduplicate real-file-name hash #:store store-dir)))))
- (mkdir-p db-dir)
- (parameterize ((sql-schema schema))
- (with-database (string-append db-dir "/db.sqlite") db
- (call-with-retrying-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)))))))))
+ (call-with-retrying-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)))))))