me
/
guix
Archived
1
0
Fork 0
Code

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.
master
Ludovic Courtès 2020-06-18 11:51:44 +02:00
parent f9a0fc9dbb
commit 97a46055ca
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
4 changed files with 77 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
gnu/build/image.scm
View File

@ -137,12 +137,13 @@ produced by #:references-graphs.. As a side effect, if RESET-TIMESTAMPS? is
true, reset timestamps on store files and, if DEDUPLICATE? is true, true, reset timestamps on store files and, if DEDUPLICATE? is true,
deduplicates files common to CLOSURE and the rest of PREFIX." deduplicates files common to CLOSURE and the rest of PREFIX."
(let ((items (call-with-input-file closure read-reference-graph))) (let ((items (call-with-input-file closure read-reference-graph)))
(register-items items (parameterize ((sql-schema schema))
#:prefix prefix (with-database (store-database-file #:prefix prefix) db
#:deduplicate? deduplicate? (register-items db items
#:reset-timestamps? reset-timestamps? #:prefix prefix
#:registration-time %epoch #:deduplicate? deduplicate?
#:schema schema))) #:reset-timestamps? reset-timestamps?
#:registration-time %epoch)))))
(define* (initialize-efi-partition root (define* (initialize-efi-partition root
#:key #:key

13
gnu/build/vm.scm
View File

@ -223,12 +223,13 @@ produced by #:references-graphs.. As a side effect, if RESET-TIMESTAMPS? is
true, reset timestamps on store files and, if DEDUPLICATE? is true, true, reset timestamps on store files and, if DEDUPLICATE? is true,
deduplicates files common to CLOSURE and the rest of PREFIX." deduplicates files common to CLOSURE and the rest of PREFIX."
(let ((items (call-with-input-file closure read-reference-graph))) (let ((items (call-with-input-file closure read-reference-graph)))
(register-items items (parameterize ((sql-schema schema))
#:prefix prefix (with-database (store-database-file #:prefix prefix) db
#:deduplicate? deduplicate? (register-items db items
#:reset-timestamps? reset-timestamps? #:prefix prefix
#:registration-time %epoch #:deduplicate? deduplicate?
#:schema schema))) #:reset-timestamps? reset-timestamps?
#:registration-time %epoch)))))
;;; ;;;

15
guix/scripts/pack.scm
View File

@ -146,13 +146,16 @@ dependencies are registered."
(define (read-closure closure) (define (read-closure closure)
(call-with-input-file closure read-reference-graph)) (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))) (let ((items (append-map read-closure '#$labels)))
(register-items items (with-database db-file db
#:state-directory #$output (register-items db items
#:deduplicate? #f #:deduplicate? #f
#:reset-timestamps? #f #:reset-timestamps? #f
#:registration-time %epoch #:registration-time %epoch)))))))
#:schema #$schema))))))
(computed-file "store-database" build (computed-file "store-database" build
#:options `(#:references-graphs ,(zip labels items)))) #:options `(#:references-graphs ,(zip labels items))))

98
guix/store/database.scm
View File

@ -37,6 +37,7 @@
#:use-module (system foreign) #:use-module (system foreign)
#:export (sql-schema #:export (sql-schema
%default-database-file %default-database-file
store-database-file
with-database with-database
path-id path-id
sqlite-register sqlite-register
@ -65,6 +66,28 @@
(unless (zero? ret) (unless (zero? ret)
((@@ (sqlite3) sqlite-error) db "sqlite-exec" 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) (define (initialize-database db)
"Initializing DB, an empty database, by creating all the tables and indexes "Initializing DB, an empty database, by creating all the tables and indexes
as specified by SQL-SCHEMA." as specified by SQL-SCHEMA."
@ -77,7 +100,10 @@ as specified by SQL-SCHEMA."
(define (call-with-database file proc) (define (call-with-database file proc)
"Pass PROC a database record corresponding to FILE. If FILE doesn't exist, "Pass PROC a database record corresponding to FILE. If FILE doesn't exist,
create it and initialize it as a new database." 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))) (db (sqlite-open file)))
;; Turn DB in "write-ahead log" mode, which should avoid SQLITE_LOCKED ;; Turn DB in "write-ahead log" mode, which should avoid SQLITE_LOCKED
;; errors when we have several readers: <https://www.sqlite.org/wal.html>. ;; 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 Use with care as it directly modifies the store! This is primarily meant to
be used internally by the daemon's build hook." be used internally by the daemon's build hook."
(register-items (list (store-info path deriver references)) (define db-file
#:prefix prefix #:state-directory state-directory (store-database-file #:prefix prefix
#:deduplicate? deduplicate? #:state-directory state-directory))
#:reset-timestamps? reset-timestamps?
#:schema schema (parameterize ((sql-schema schema))
#:log-port (%make-void-port "w"))) (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 (define %epoch
;; When it all began. ;; When it all began.
(make-time time-utc 0 1)) (make-time time-utc 0 1))
(define* (register-items items (define* (register-items db items
#:key prefix state-directory #:key prefix
(deduplicate? #t) (deduplicate? #t)
(reset-timestamps? #t) (reset-timestamps? #t)
registration-time registration-time
(schema (sql-schema))
(log-port (current-error-port))) (log-port (current-error-port)))
"Register all of ITEMS, a list of <store-info> records as returned by "Register all of ITEMS, a list of <store-info> records as returned by
'read-reference-graph', in the database under PREFIX/STATE-DIRECTORY. ITEMS 'read-reference-graph', in DB. ITEMS must be in topological order (with
must be in topological order (with leaves first.) If the database is leaves first.) REGISTRATION-TIME must be the registration time to be recorded
initially empty, apply SCHEMA to initialize it. REGISTRATION-TIME must be the in the database; #f means \"now\". Write a progress report to LOG-PORT."
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)))
(define store-dir (define store-dir
(if prefix (if prefix
(string-append prefix %storedir) (string-append prefix %storedir)
@ -438,17 +451,14 @@ Write a progress report to LOG-PORT."
(when deduplicate? (when deduplicate?
(deduplicate real-file-name hash #:store store-dir))))) (deduplicate real-file-name hash #:store store-dir)))))
(mkdir-p db-dir) (call-with-retrying-transaction db
(parameterize ((sql-schema schema)) (lambda ()
(with-database (string-append db-dir "/db.sqlite") db (let* ((prefix (format #f "registering ~a items" (length items)))
(call-with-retrying-transaction db (progress (progress-reporter/bar (length items)
(lambda () prefix log-port)))
(let* ((prefix (format #f "registering ~a items" (length items))) (call-with-progress-reporter progress
(progress (progress-reporter/bar (length items) (lambda (report)
prefix log-port))) (for-each (lambda (item)
(call-with-progress-reporter progress (register db item)
(lambda (report) (report))
(for-each (lambda (item) items)))))))
(register db item)
(report))
items)))))))))