From 97a46055ca9f72986740c26a5406b5138176ca61 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 18 Jun 2020 11:51:44 +0200 Subject: 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. --- guix/scripts/pack.scm | 15 +++++--- guix/store/database.scm | 98 +++++++++++++++++++++++++++---------------------- 2 files changed, 63 insertions(+), 50 deletions(-) (limited to 'guix') 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: . @@ -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 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))))))) -- cgit v1.2.3