>From adba9061739cd9afff9d404f871f66ce36147dd2 Mon Sep 17 00:00:00 2001 From: Caleb Ristvedt Date: Wed, 13 Feb 2019 02:19:42 -0600 Subject: [PATCH 2/2] guix: store: Register derivation outputs. * guix/store/database.scm (register-output-sql, derivation-outputs-sql): new variables. (registered-derivation-outputs): new procedure. ((guix derivations), (guix store)): used for and derivation-path?, respectively. (register-items): if item is a derivation, also register its outputs. * tests/store-database.scm (register-path): first register a dummy derivation for the test file, and check that its outputs are registered in the DerivationOutputs table and are equal to what was specified in the dummy derivation. --- guix/store/database.scm | 41 ++++++++++++++++++++++++++++++++++++++++ tests/store-database.scm | 30 ++++++++++++++++++++++++++++- 2 files changed, 70 insertions(+), 1 deletion(-) diff --git a/guix/store/database.scm b/guix/store/database.scm index af7f82b049..b89d81d770 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -21,6 +21,8 @@ #:use-module (sqlite3) #:use-module (guix config) #:use-module (guix serialization) + #:use-module (guix derivations) + #:use-module (guix store) #:use-module (guix store deduplication) #:use-module (guix base16) #:use-module (guix progress) @@ -42,6 +44,7 @@ sqlite-register register-path register-items + registered-derivation-outputs %epoch reset-timestamps)) @@ -282,6 +285,26 @@ be used internally by the daemon's build hook." ;; When it all began. (make-time time-utc 0 1)) +(define derivation-outputs-sql "SELECT id, path FROM DerivationOutputs WHERE +drv in (SELECT id from ValidPaths where path = :drv)") + +(define (registered-derivation-outputs db drv) + "Get the list of (id, output-path) pairs registered for DRV." + (let ((stmt (sqlite-prepare db derivation-outputs-sql #:cache? #t))) + (sqlite-bind-arguments stmt #:drv drv) + (let ((result (sqlite-fold (lambda (current prev) + (match current + (#(id path) + (cons (cons id path) + prev)))) + '() stmt))) + (sqlite-finalize stmt) + result))) + +(define register-output-sql + "INSERT OR REPLACE INTO DerivationOutputs (drv, id, path) SELECT id, :outid, +:outpath FROM ValidPaths WHERE path = :drvpath;") + (define* (register-items items #:key prefix state-directory (deduplicate? #t) @@ -330,6 +353,21 @@ Write a progress report to LOG-PORT." (define real-file-name (string-append store-dir "/" (basename (store-info-item item)))) + (define (register-derivation-outputs drv) + "Register all output paths of DRV as being produced by it (note that +this doesn't mean 'already produced by it', but rather just 'associated with +it')." + (let ((stmt (sqlite-prepare db register-output-sql #:cache? #t))) + (for-each (match-lambda + ((outid . ($ path)) + (sqlite-bind-arguments stmt + #:drvpath (derivation-file-name + drv) + #:outid outid + #:outpath path) + (sqlite-fold noop #f stmt))) + (derivation-outputs drv)) + (sqlite-finalize stmt))) ;; When TO-REGISTER is already registered, skip it. This makes a ;; significant differences when 'register-closures' is called @@ -345,6 +383,9 @@ Write a progress report to LOG-PORT." (bytevector->base16-string hash)) #:nar-size nar-size #:time registration-time) + (when (derivation-path? real-file-name) + (register-derivation-outputs (read-derivation-from-file + real-file-name))) (when deduplicate? (deduplicate real-file-name hash #:store store-dir))))) diff --git a/tests/store-database.scm b/tests/store-database.scm index 4d91884250..d5fb916586 100644 --- a/tests/store-database.scm +++ b/tests/store-database.scm @@ -20,6 +20,7 @@ #:use-module (guix tests) #:use-module (guix store) #:use-module (guix store database) + #:use-module (guix derivations) #:use-module ((guix utils) #:select (call-with-temporary-output-file)) #:use-module (srfi srfi-26) #:use-module (srfi srfi-64)) @@ -44,14 +45,41 @@ (drv (string-append file ".drv"))) (call-with-output-file file (cut display "This is a fake store item.\n" <>)) + (when (valid-path? %store drv) + (delete-paths %store (list drv))) + (call-with-output-file drv + (lambda (port) + ;; XXX: we should really go from derivation to output path as is + ;; usual, currently any verification done on this derivation will + ;; cause an error. + (write-derivation ((@@ (guix derivations) make-derivation) + ;; outputs + (list (cons "out" + ((@@ (guix derivations) + make-derivation-output) + file + #f + #f + #f))) + ;; inputs sources system builder args + '() '() "" "" '() + ;; env-vars filename + '() drv) + port))) + (register-path drv) (register-path file #:references (list ref) #:deriver drv) (and (valid-path? %store file) (equal? (references %store file) (list ref)) - (null? (valid-derivers %store file)) + ;; We expect the derivation outputs to be automatically + ;; registered. + (not (null? (valid-derivers %store file))) (null? (referrers %store file)) + (equal? (with-database %default-database-file db + (registered-derivation-outputs db drv)) + `(("out" . ,file))) (list (stat:mtime (lstat file)) (stat:mtime (lstat ref))))))) -- 2.20.0