[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
18/19: guix: store: Adapt to using register-items instead of register-pa
|
From: |
guix-commits |
|
Subject: |
18/19: guix: store: Adapt to using register-items instead of register-path. |
|
Date: |
Tue, 29 Jan 2019 14:19:52 -0500 (EST) |
reepca pushed a commit to branch guile-daemon
in repository guix.
commit 15bedf0f3a48818452cfe604451964f5632f10a2
Author: Caleb Ristvedt <address@hidden>
Date: Tue Jan 29 13:00:01 2019 -0600
guix: store: Adapt to using register-items instead of register-path.
This also removes (guix sql) and adapts the relevant code to instead use
features of guile-sqlite3.
* guix/store.scm (register-path): removed. Originally removed upstream,
reintroduced accidentally while rebasing, now gone again.
* guix/store/build-derivations.scm (get-output-specs): now returns a list of
<store-info> objects.
(scan-for-references): Don't get the nar-size or hash since register-items
will do it either way.
((guix build store-copy)): Import this module for <store-info> definition.
((guix store deduplication)): Don't need this imported anymore since
counting-wrapper-port isn't used.
(topologically-sorted): New procedure. None of the existing ones did quite
what I wanted.
(%build-derivations): Use topologically-sorted.
* guix/store/database.scm (output-path-id-sql, references-sql): Use colons
instead of dollar signs to work with new guile-sqlite3 features.
(file-closure, outputs-exist?): Updated to no longer depend on (guix sql).
(register-derivation-output): Removed, replaced with
register-derivation-outputs inside register-items.
(file-closure): Fixed to no longer unconditionally add the given path to
references-vlist, as it may already be there - there are no longer
duplicate
entries in the vlist.
* guix/sql.scm: Removed.
* .dir-locals.el (call-with-transaction): add indentation support.
(with-sql-statement, with-sql-statements, with-sql-database, run-sql,
run-statement): remove indentation support, as (guix sql) is no more.
---
guix/sql.scm | 232 ---------------------------------------
guix/store.scm | 69 ------------
guix/store/build-derivations.scm | 102 +++++++++++------
guix/store/database.scm | 111 +++++++------------
4 files changed, 108 insertions(+), 406 deletions(-)
diff --git a/guix/sql.scm b/guix/sql.scm
deleted file mode 100644
index 0012868..0000000
--- a/guix/sql.scm
+++ /dev/null
@@ -1,232 +0,0 @@
-;;; Copyright © 2017 Caleb Ristvedt <address@hidden>
-;;;
-;;; This file is part of GNU Guix.
-;;;
-;;; GNU Guix is free software; you can redistribute it and/or modify it
-;;; under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 3 of the License, or (at
-;;; your option) any later version.
-;;;
-;;; GNU Guix is distributed in the hope that it will be useful, but
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
-
-
-(define-module (guix sql)
- #:use-module (sqlite3)
- #:use-module (system foreign)
- #:use-module (rnrs bytevectors)
- #:use-module (srfi srfi-9)
- #:export (sqlite-last-insert-rowid
- sql-parameters
- with-sql-statement
- with-sql-database
- run-sql
- run-statement
- single-result
- with-sql-statements)
- #:re-export (sqlite-step
- sqlite-fold
- sqlite-fold-right
- sqlite-map
- sqlite-prepare
- sqlite-reset
- sqlite-finalize))
-
-;; Miscellaneous SQL stuff. Mostly macros.
-
-
-;; This structure and the procedures that operate on it make it possible to
-;; open an sqlite database and compile sql statements only when
-;; necessary. Whichever macro opens the database is also responsible for
-;; closing it, and any macros using that database or statements compiled for
-;; it within the scope of that macro will use what is already there.
-(define-record-type <guix-database>
- (make-guix-database sql-database statement-cache)
- guix-database?
- (sql-database guix-sql-database)
- (statement-cache db-statement-cache))
-
-(define (open-guix-database location)
- (make-guix-database (sqlite-open location)
- (make-hash-table)))
-
-(define (close-guix-database db)
- (hash-for-each (lambda (key value)
- (sqlite-finalize value))
- (db-statement-cache db))
- (sqlite-close (guix-sql-database db)))
-
-(define (maybe-compile-statement db sql)
- (let ((statement (hash-ref (db-statement-cache db) sql)))
- (or statement
- (let ((new-statement (sqlite-prepare (guix-sql-database db)
- sql)))
- (hash-set! (db-statement-cache db)
- sql
- new-statement)
- new-statement))))
-
-
-;; This really belongs in guile-sqlite3, as can be seen from the @@s.
-(define sqlite-last-insert-rowid
- (let ((last-rowid (pointer->procedure
- int
- (dynamic-func "sqlite3_last_insert_rowid"
- (@@ (sqlite3) libsqlite3))
- (list '*))))
- (lambda (db)
- "Gives the row id of the last inserted row in DB."
- (last-rowid ((@@ (sqlite3) db-pointer) (guix-sql-database db))))))
-
-(define sqlite-parameter-index
- (let ((param-index (pointer->procedure
- int
- (dynamic-func "sqlite3_bind_parameter_index"
- (@@ (sqlite3) libsqlite3))
- (list '* '*))))
- (lambda (statement key)
- "Gives the index of an sqlite parameter for a certain statement with a
-certain (string) name."
- (param-index ((@@ (sqlite3) stmt-pointer) statement)
- (string->pointer key "utf-8")))))
-
-
-(define-syntax sql-parameters
- (syntax-rules ()
- "Converts key-value pairs into sqlite bindings for a specific statement."
- ((sql-parameters statement (name1 val1) (name2 val2) (name3 val3) ...)
- (begin (sqlite-bind statement
- (sqlite-parameter-index statement name1)
- val1)
- (sql-parameters statement (name2 val2) (name3 val3) ...)))
- ((sql-parameters statement (name value))
- (sqlite-bind statement
- (sqlite-parameter-index statement name)
- value))))
-
-(define* (step-all statement #:optional (callback noop))
- "Step until statement is completed. Return number of rows."
- ;; Where "number of rows" is assumed to be number of steps taken, excluding
- ;; the last one.
- (let maybe-step ((ret (sqlite-step statement))
- (count 0))
- (if ret
- (maybe-step (sqlite-step statement) (+ count 1))
- count)))
-
-;; I get the feeling schemers have probably already got this "with" business
-;; much more automated than this...
-(define-syntax with-sql-statement
- (syntax-rules ()
- "Automatically prepares statements and then finalizes statements once the
-scope of this macro is left. Also with built-in sqlite parameter binding via
-key-value pairs."
- ((with-sql-statement db sql statement-var
- ((name1 val1) (name2 val2) ...)
- exps ...)
- (let ((statement-var (maybe-compile-statement db sql)))
- (dynamic-wind noop
- (lambda ()
- (sql-parameters statement-var
- (name1 val1)
- (name2 val2) ...)
- exps ...)
- (lambda ()
- (sqlite-reset statement-var)))))
- ((with-sql-statement db sql statement-var () exps ...)
- (let ((statement-var (maybe-compile-statement db sql)))
- (dynamic-wind noop
- (lambda ()
- exps ...)
- (lambda ()
- (sqlite-reset statement-var)))))))
-
-(define-syntax with-sql-statements
- (syntax-rules ()
- "Like with-sql-statement, but with multiple statements."
- ((with-sql-statements db ((sql statement-var bindings))
- exps ...)
- (with-sql-statement db sql statement-var bindings
- exps ...))
- ((with-sql-statements db ((sql statement-var bindings) stmt-clause-rest
...)
- exps ...)
- (with-sql-statements db (stmt-clause-rest ...)
- (with-sql-statement db sql statement-var bindings
- exps ...)))))
-
-
-(define-syntax with-sql-database
- (syntax-rules ()
- "Automatically closes the database once the scope of this macro is left
-unless the database was already open - that is, LOCATION wasn't a string but a
-<sqlite-db>"
- ((with-sql-database location db-var exps ...)
- (let* ((already-open? (guix-database? location))
- (db-var (if already-open?
- location
- (open-guix-database location))))
- (dynamic-wind noop
- (lambda ()
- exps ...)
- (lambda ()
- (unless already-open?
- (close-guix-database db-var))))))))
-
-(define-syntax run-sql
- (syntax-rules ()
- "For one-off queries that don't get repeated on the same
-database. Everything after database and sql source should be 2-element lists
-containing the sql placeholder name and the value to use. Returns the number
-of rows."
- ((run-sql db sql (name1 val1) (name2 val2) ...)
- (let ((statement (maybe-compile-statement db sql)))
- (dynamic-wind noop
- (lambda ()
- (sql-parameters statement
- (name1 val1)
- (name2 val2) ...)
- (step-all statement))
- (lambda ()
- (sqlite-reset statement)))))
- ((run-sql db sql)
- (let ((statement (maybe-compile-statement db sql)))
- (dynamic-wind noop
- (lambda ()
- (step-all statement))
- (lambda ()
- (sqlite-reset statement)))))))
-
-(define-syntax run-statement
- (syntax-rules ()
- "For compiled statements that may be run multiple times. Everything after
-database and sql source should be 2-element lists containing the sql
-placeholder name and the value to use. Returns the number of rows."
- ((run-sql db statement (name1 val1) (name2 val2) ...)
- (dynamic-wind noop
- (lambda ()
- (sql-parameters statement
- (name1 val1)
- (name2 val2) ...)
- (step-all statement))
- (lambda ()
- (sqlite-reset statement))))
- ((run-sql db statement)
- (dynamic-wind noop
- (lambda ()
- (step-all statement))
- (lambda ()
- (sqlite-reset statement))))))
-
-
-
-(define (single-result statement)
- "Gives the first element of the first row returned by statement."
- (let ((row (sqlite-step statement)))
- (if row
- (vector-ref row 0)
- #f)))
diff --git a/guix/store.scm b/guix/store.scm
index 748b455..5c21360 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -1524,75 +1524,6 @@ This makes sense only when the daemon was started with
'--cache-failures'."
-;; TODO: Handle databases not existing yet (what should the default behavior
-;; be? The C++ version checks for a number in the file "schema" in the
-;; database directory and compares it to a constant, and uses that to decide
-;; whether to "upgrade" or initialize the database).
-
-(define* (register-path path
- #:key (references '()) deriver prefix state-directory)
- ;; 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.
- "Register PATH as a valid store file, with REFERENCES as its list of
-references, and DERIVER as its deriver (.drv that led to it.) If PREFIX is
-given, it must be the name of the directory containing the new store to
-initialize; if STATE-DIRECTORY is given, it must be a string containing the
-absolute file name to the state directory of the store being initialized.
-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."
- (false-if-exception
- (let* ((db-dir (cond
- (state-directory
- (string-append state-directory "/db"))
- (prefix
- ;; If prefix is specified, the value of NIX_STATE_DIR
- ;; (which affects %state-directory) isn't supposed to
- ;; affect db-dir, only the compile-time-customized
- ;; default should.
- (string-append prefix %localstatedir "/guix/db"))
- (else
- %store-database-directory)))
- (store-dir (if prefix
- ;; same situation as above
- (string-append prefix %storedir)
- %store-directory))
- (to-register (if prefix
- (string-append %storedir "/" (basename path))
- ;; note: we assume here that if path is, for
- ;; example, /foo/bar/gnu/store/thing.txt and prefix
- ;; isn't given, then an environment variable has
- ;; been used to change the store directory to
- ;; /foo/bar/gnu/store, since otherwise real-path
- ;; would end up being /gnu/store/thing.txt, which is
- ;; probably not the right file in this case.
- path))
- (real-path (string-append store-dir "/" (basename path))))
- (let-values (((hash nar-size)
- (nar-sha256 real-path)))
- (sqlite-register
- #:dbpath (string-append db-dir "/db.sqlite")
- #:path to-register
- #:references references
- #:deriver deriver
- #:hash (string-append "sha256:"
- (bytevector->base16-string hash))
- #:nar-size nar-size)
- ;; reset-timestamps prints a message on each invocation that we probably
- ;; don't want.
- (with-output-to-port
- (%make-void-port "w")
- (lambda ()
- (reset-timestamps real-path)))
- (deduplicate real-path store-dir hash)
- ;; If we've made it this far without an exception, I guess we've
- ;; probably succeeded?
- #t))))
-
;;;
;;; Store monad.
diff --git a/guix/store/build-derivations.scm b/guix/store/build-derivations.scm
index 264e028..344756d 100644
--- a/guix/store/build-derivations.scm
+++ b/guix/store/build-derivations.scm
@@ -19,7 +19,6 @@
;;; For building derivations.
(define-module (guix store build-derivations)
- #:use-module (guix store deduplication)
#:use-module (guix derivations)
#:use-module (guix store)
#:use-module (guix store database)
@@ -38,6 +37,7 @@
#:use-module ((guix build utils) #:select (delete-file-recursively
mkdir-p
copy-recursively))
+ #:use-module (guix build store-copy)
#:use-module (gnu system file-systems)
#:use-module (gnu build linux-container)
#:use-module (ice-9 textual-ports)
@@ -89,17 +89,17 @@
output-path)))
(define (get-output-specs drv possible-references)
- "Gets hash, size, and reference info from each output of DRV."
+ "Returns a list of <store-info> objects, one for each output of DRV."
(map (match-lambda
((outid . ($ <derivation-output> output-path))
- (let-values (((references hash nar-size)
- (scan-for-references output-path
- ;; outputs can reference
- ;; themselves or other outputs of
- ;; the same derivation.
- (append (output-paths drv)
- possible-references))))
- (list outid output-path references hash nar-size))))
+ (let ((references
+ (scan-for-references output-path
+ ;; outputs can reference
+ ;; themselves or other outputs of
+ ;; the same derivation.
+ (append (output-paths drv)
+ possible-references))))
+ (store-info output-path (derivation-file-name drv) references))))
(derivation-outputs drv)))
(define (builtin-download drv)
@@ -734,17 +734,11 @@ detected. STRINGS must not be empty."
"Scans for literal references in FILE as long as they happen to be in
POSSIBILITIES. Returns the list of references found, the sha256 hash of the
nar, and the length of the nar."
- (let*-values (((hash-port get-hash) (open-sha256-port))
- ((scanning-port get-references)
- (scanning-wrapper-port hash-port possibilities))
- ((counting-port) (counting-wrapper-port scanning-port)))
- (write-file file counting-port)
- (force-output counting-port)
- (let ((size (port-position counting-port)))
- (close-port counting-port)
- (values (get-references)
- (get-hash)
- size))))
+ (let*-values (((scanning-port get-references)
+ (scanning-wrapper-port (%make-void-port "w") possibilities)))
+ (write-file file scanning-port)
+ (force-output scanning-port)
+ (get-references)))
;; XXX: make this configurable. Maybe I should read some more about those
;; parameters I've heard about...
@@ -778,6 +772,57 @@ nar, and the length of the nar."
(if (zero? (run-builder build-env))
(get-output-specs drv store-inputs)
#f)))
+(define (topologically-sorted store-infos)
+ "Returns STORE-INFOS in topological order or throws CYCLE-DETECTED if no
+such order exists."
+ (define path->store-info
+ (let loop ((infos store-infos)
+ (mapping vlist-null))
+ (match infos
+ ((($ (@@ (guix build store-copy) <store-info>)
+ item deriver references) . tail)
+ (loop tail (vhash-cons item (car infos) mapping)))
+ (()
+ (lambda (path)
+ (let ((pair (vhash-assoc path mapping)))
+ (and pair
+ (cdr pair))))))))
+
+ (define (references-of store-info)
+ ;; We need to pretend that self-references don't exist...
+ (fold (lambda (current prev)
+ (let ((info (path->store-info current)))
+ (or (and (not (equal? info store-info))
+ info
+ (cons info prev))
+ prev)))
+ '()
+ (store-info-references store-info)))
+
+ (reverse
+ (let visit ((infos store-infos)
+ (visited (set))
+ (dependents (set))
+ (result '()))
+ (match infos
+ ((head . tail)
+ (if (set-contains? visited head)
+ (if (set-contains? dependents head)
+ (throw 'cycle-detected head)
+ (visit tail visited dependents result))
+ (call-with-values
+ (lambda ()
+ (visit (references-of head)
+ (set-insert head visited)
+ (set-insert head dependents)
+ result))
+ (lambda (result visited)
+ (visit tail
+ visited
+ dependents
+ (cons head result))))))
+ (()
+ (values result visited))))))
(define (%build-derivation drv)
"Given a <derivation> DRV, builds/substitutes the derivation unconditionally
@@ -791,20 +836,7 @@ even if its outputs already exist."
(maybe-use-builtin drv)
(do-derivation-build drv))))
(if output-specs
- (for-each (match-lambda
- ((outid output-path references hash nar-size)
- (register-derivation-output %store-database
- (derivation-file-name drv)
- outid
- output-path
- references
- nar-size
- (string-append
- "sha256:"
- (bytevector->base16-string
- hash))))
- (assimilate-path output-path))
- output-specs)
+ (register-items (topologically-sorted output-specs))
(throw 'derivation-build-failed drv))))
(define (ensure-input-outputs-exist inputs)
diff --git a/guix/store/database.scm b/guix/store/database.scm
index 20615eb..587b2fb 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -396,31 +396,27 @@ ValidPaths WHERE ValidPaths.id = DerivationOutputs.drv)
AND id = $id")
(define output-path-id-sql
"SELECT id FROM ValidPaths WHERE path IN (SELECT path FROM DerivationOutputs
-WHERE DerivationOutputs.id = $id AND drv IN (SELECT id FROM ValidPaths WHERE
-path = $drvpath))")
+WHERE DerivationOutputs.id = :id AND drv IN (SELECT id FROM ValidPaths WHERE
+path = :drvpath))")
;; "SELECT id FROM ValidPaths WHERE ValidPaths.path IN (SELECT path FROM
;; DerivationOutputs WHERE $drvpath IN (SELECT path FROM ValidPaths WHERE
;; ValidPaths.id = DerivationOutputs.drv) AND id = $id)"
(define* (outputs-exist? drv-path outputs
- #:optional (database %store-database))
+ #:optional (database %default-database-file))
"Determines whether all output labels in OUTPUTS exist as built outputs of
-drv-path."
- (with-sql-database
- database db
- (with-sql-statement db output-path-id-sql output-path-id
- (("$drvpath" drv-path))
- (fold
- (lambda (output-label prev)
- (and prev
- (begin
- (sqlite-reset output-path-id)
- (sql-parameters output-path-id
- ("$id" output-label))
- (single-result output-path-id))))
- #t
- outputs))))
+DRV-PATH."
+ (with-database database db
+ (let ((stmt (sqlite-prepare db output-path-id-sql)))
+ (sqlite-bind-arguments stmt #:drvpath drv-path)
+ (let ((result (every (lambda (out-id)
+ (sqlite-reset stmt)
+ (sqlite-bind-arguments stmt #:id out-id)
+ (sqlite-step stmt))
+ outputs)))
+ (sqlite-finalize stmt)
+ result))))
(define referrers-sql
"SELECT path FROM ValidPaths WHERE id IN (SELECT referrer FROM Refs WHERE
@@ -428,60 +424,35 @@ reference IN (SELECT id FROM ValidPaths WHERE path =
$path))")
(define references-sql
"SELECT path FROM ValidPaths WHERE id IN (SELECT reference FROM Refs WHERE
-referrer IN (SELECT id FROM ValidPaths WHERE path = $path))")
+referrer IN (SELECT id FROM ValidPaths WHERE path = :path))")
(define* (file-closure path #:key
- (database %store-database)
+ (database %default-database-file)
(list-so-far vlist-null))
"Returns a vlist containing the store paths referenced by PATH, the store
paths referenced by those paths, and so on."
- (with-sql-database
- database db
- (with-sql-statement
- db references-sql get-references ()
-
- ;; to make it possible to go depth-first we need to get all the
- ;; references of an item first or we'll have re-entrancy issues with
- ;; the get-references statement.
- (define (references-of path)
- ;; There are no problems with resetting an already-reset
- ;; statement.
- (sqlite-reset get-references)
- (sql-parameters get-references ("$path" path))
- (sqlite-fold (lambda (row prev)
- (cons (vector-ref row 0) prev))
- '()
- get-references))
-
- (let %file-closure ((references-vlist (vhash-cons path
- #t
- list-so-far))
- (path path))
- (fold (lambda (ref prev)
- (if (vhash-assoc ref prev)
- prev
- (%file-closure (vhash-cons ref #t prev)
- ref)))
- references-vlist
- (references-of path))))))
-
-(define register-output-sql
- "INSERT OR REPLACE INTO DerivationOutputs (drv, id, path) SELECT id, $outid,
-$outpath FROM ValidPaths WHERE path = $drvpath")
-
-(define (register-derivation-output database drv-path outid output-path
- references nar-size hash)
- (with-sql-database
- database db
- (with-sql-statement db
- register-output-sql register-output
- (("$drvpath" drv-path)
- ("$outid" outid)
- ("$outpath" output-path))
- (let ((id (sqlite-register #:dbpath db
- #:path output-path
- #:references references
- #:deriver drv-path
- #:hash hash
- #:nar-size nar-size)))
- (run-statement db register-output)))))
+ (with-database database db
+ (let ((get-references (sqlite-prepare db references-sql)))
+ ;; to make it possible to go depth-first we need to get all the
+ ;; references of an item first or we'll have re-entrancy issues with
+ ;; the get-references statement.
+ (define (references-of path)
+ ;; There are no problems with resetting an already-reset
+ ;; statement.
+ (sqlite-reset get-references)
+ (sqlite-bind-arguments get-references #:path path)
+ (sqlite-fold (lambda (row prev)
+ (cons (vector-ref row 0) prev))
+ '()
+ get-references))
+
+ (let ((result
+ (let %file-closure ((path path)
+ (references-vlist list-so-far))
+ (if (vhash-assoc path references-vlist)
+ references-vlist
+ (fold %file-closure
+ (vhash-cons path #t references-vlist)
+ (references-of path))))))
+ (sqlite-finalize get-references)
+ result))))
- 09/19: guix: register-path: return #t on success., (continued)
- 09/19: guix: register-path: return #t on success., guix-commits, 2019/01/29
- 03/19: guix: register-path: Honor environment variables., guix-commits, 2019/01/29
- 06/19: guix: register-path: use new %store-database-directory, guix-commits, 2019/01/29
- 10/19: guix: register-path: use new %store-database-directory, guix-commits, 2019/01/29
- 16/19: build-derivations: Leaked environment variables more robust., guix-commits, 2019/01/29
- 19/19: gnu: linux-container: Make it more suitable for derivation-building., guix-commits, 2019/01/29
- 17/19: guix: store: Make register-items transactional, register drv outputs, guix-commits, 2019/01/29
- 14/19: build-derivations: initial build-group support, guix-commits, 2019/01/29
- 15/19: linux-container: don't include /dev/ptmx or /dev/pts from host., guix-commits, 2019/01/29
- 13/19: build-derivations: use call-with-container, guix-commits, 2019/01/29
- 18/19: guix: store: Adapt to using register-items instead of register-path.,
guix-commits <=
- 11/19: guix/store/build-derivations.scm: new module., guix-commits, 2019/01/29