>From ce4a322446d1865791686b1e4573973573bdcdfc Mon Sep 17 00:00:00 2001 From: Caleb Ristvedt Date: Sat, 3 Jun 2017 02:26:05 -0500 Subject: [PATCH 1/7] guix: register-path: Implement prototype in scheme. * guix/store.scm (register-path): reimplement in scheme. * guix/sql.scm: New file. --- gnu/packages/package-management.scm | 3 +- guix/sql.scm | 224 ++++++++++++++++++++++++++++++++++++ guix/store.scm | 78 ++++++++++--- 3 files changed, 286 insertions(+), 19 deletions(-) create mode 100644 guix/sql.scm diff --git a/gnu/packages/package-management.scm b/gnu/packages/package-management.scm index af91ec1d7..50be3a23f 100644 --- a/gnu/packages/package-management.scm +++ b/gnu/packages/package-management.scm @@ -250,7 +250,8 @@ (propagated-inputs `(("gnutls" ,gnutls/guile-2.2) ;for 'guix download' & co. ("guile-json" ,guile-json) - ("guile-ssh" ,guile-ssh))) + ("guile-ssh" ,guile-ssh) + ("guile-sqlite3" ,guile-sqlite3))) (home-page "https://www.gnu.org/software/guix/") (synopsis "Functional package manager for installed software packages and versions") diff --git a/guix/sql.scm b/guix/sql.scm new file mode 100644 index 000000000..b1e0c0aa4 --- /dev/null +++ b/guix/sql.scm @@ -0,0 +1,224 @@ +(define-module (guix sql) + #:use-module (sqlite3) + #:use-module (system foreign) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-9) + #:export (sqlite-register)) + +;; Miscellaneous SQL stuff, currently just setup for sqlite-register. Mostly +;; macros. + +;; 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) db))))) + + +;; Should I go from key->index here or try to change that in guile-sqlite3? +(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 name1 val1) + (sql-parameters statement (name2 val2) (name3 val3) ...))) + ((sql-parameters statement (name value)) + (sqlite-bind 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 ret (+ 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 (sqlite-prepare db sql))) + (dynamic-wind noop + (lambda () + (sql-parameters statement-var + (name1 val1) + (name2 val2) ...) + exps ...) + (lambda () + (sqlite-finalize statement-var))))) + ((with-sql-statement db sql statement-var () exps ...) + (let ((statement-var (sqlite-prepare db sql))) + (dynamic-wind noop + (lambda () + exps ...) + (lambda () + (sqlite-finalize statement-var))))))) + +(define-syntax with-sql-database + (syntax-rules () + "Automatically closes the database once the scope of this macro is left." + ((with-sql-database location db-var exps ...) + (let ((db-var (sqlite-open location))) + (dynamic-wind noop + (lambda () + exps ...) + (lambda () + (sqlite-close 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 (sqlite-prepare db sql))) + (dynamic-wind noop + (lambda () + (sql-parameters statement + (name1 val1) + (name2 val2) ...) + (step-all statement)) + (lambda () + (sqlite-finalize statement))))) + ((run-sql db sql) + (let ((statement (sqlite-prepare db sql))) + (dynamic-wind noop + (lambda () + (step-all statement)) + (lambda () + (sqlite-finalize 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 path-id-sql + "SELECT id FROM ValidPaths WHERE path = $path") + +(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))) + +(define* (path-id db path) + "If the path \"path\" exists in the ValidPaths table, return its +id. Otherwise, return #f. If you already have a compiled statement for this +purpose, you can give it as statement." + (with-sql-statement db path-id-sql statement + (;("$path" path) + (1 path)) + (single-result statement))) + + +(define update-sql + "UPDATE ValidPaths SET hash = $hash, registrationTime = $time, deriver = +$deriver, narSize = $size WHERE id = $id") + +(define insert-sql + "INSERT INTO ValidPaths (path, hash, registrationTime, deriver, narSize) +VALUES ($path, $hash, $time, $deriver, $size)") + +(define* (update-or-insert #:key db path deriver hash nar-size time) + "The classic update-if-exists and insert-if-doesn't feature that sqlite +doesn't exactly have... they've got something close, but it involves deleting +and re-inserting instead of updating, which causes problems with foreign keys, +of course. Returns the row id of the row that was modified or inserted." + (let ((id (path-id db path))) + (if id + (begin + (run-sql db update-sql + ;; As you may have noticed, sqlite-bind doesn't behave + ;; exactly how I was expecting... + ;; ("$id" id) + ;; ("$deriver" deriver) + ;; ("$hash" hash) + ;; ("$size" nar-size) + ;; ("$time" time) + (5 id) + (3 deriver) + (1 hash) + (4 nar-size) + (2 time)) + id) + (begin + (run-sql db insert-sql + ;; ("$path" path) + ;; ("$deriver" deriver) + ;; ("$hash" hash) + ;; ("$size" nar-size) + ;; ("$time" time) + (1 path) + (4 deriver) + (2 hash) + (5 nar-size) + (3 time)) + (sqlite-last-insert-rowid db))))) + +(define add-reference-sql + "INSERT OR IGNORE INTO Refs (referrer, reference) SELECT $referrer, id +FROM ValidPaths WHERE path = $reference") + +(define (add-references db referrer references) + "referrer is the id of the referring store item, references is a list +containing store item paths being referred to. Note that all of the store +items in \"references\" should already be registered." + (with-sql-statement db add-reference-sql add-reference-statement () + (for-each (lambda (reference) + (run-statement db + add-reference-statement + ;("$referrer" referrer) + ;("$reference" reference) + (1 referrer) + (2 reference))) + references))) + +;; XXX figure out caching of statement and database objects... later +(define* (sqlite-register #:key dbpath path references deriver hash nar-size) + "Registers this stuff in a database specified by DBPATH. PATH is the string +path of some store item, REFERENCES is a list of string paths which the store +item PATH refers to (they need to be already registered!), DERIVER is a string +path of the derivation that created the store item PATH, HASH is the +base16-encoded sha256 hash of the store item denoted by PATH (prefixed with +\"sha256:\") after being converted to nar form, and nar-size is the size in +bytes of the store item denoted by PATH after being converted to nar form." + (with-sql-database dbpath db + (let ((id (update-or-insert #:db db + #:path path + #:deriver deriver + #:hash hash + #:nar-size nar-size + #:time (current-time)))) + (add-references db id references)))) diff --git a/guix/store.scm b/guix/store.scm index c94dfea95..a62fcf3f1 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -27,6 +27,7 @@ #:use-module (guix hash) #:autoload (guix build syscalls) (terminal-columns) #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) #:use-module (ice-9 binary-ports) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) @@ -41,6 +42,8 @@ #:use-module (ice-9 vlist) #:use-module (ice-9 popen) #:use-module (web uri) + #:use-module (sqlite3) + #:use-module (guix sql) #:export (%daemon-socket-uri %gc-roots-directory %default-substitute-urls @@ -1206,32 +1209,71 @@ The result is always the empty list unless the daemon was started with This makes sense only when the daemon was started with '--cache-failures'." boolean) + +;; Would it be better to just make WRITE-FILE give size as well? I question +;; the general utility of this approach. +(define (counting-wrapper-port output-port) + "Some custom ports don't implement GET-POSITION at all. But if we want to +figure out how many bytes are being written, we will want to use that. So this +makes a wrapper around a port which implements GET-POSITION." + (let ((byte-count 0)) + (make-custom-binary-output-port "counting-wrapper" + (lambda (bytes offset count) + (set! byte-count + (+ byte-count count)) + (put-bytevector output-port bytes + offset count) + count) + (lambda () + byte-count) + #f + (lambda () + (close-port output-port))))) + + +(define (nar-sha256 file) + "Gives the sha256 hash of a file and the size of the file in nar form." + (let-values (((port get-hash) (open-sha256-port))) + (let ((wrapper (counting-wrapper-port port))) + (write-file file wrapper) + (force-output wrapper) + (force-output port) + (let ((hash (get-hash)) + (size (port-position wrapper))) + (close-port wrapper) + (values hash + size))))) + +;; TODO: make this canonicalize store items that are registered. This involves +;; setting permissions and timestamps, I think. Also, run a "deduplication +;; pass", whatever that involves. Also, honor environment variables. Also, +;; handle databases not existing yet (what should the default behavior be? +;; Figuring out how the C++ stuff currently does it sounds like a lot of +;; grepping for global variables...) + (define* (register-path path - #:key (references '()) deriver prefix - state-directory) + #:key (references '()) deriver (prefix "") + (state-directory + (string-append prefix %state-directory))) "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 -not #f, it must be the name of the directory containing the new store to -initialize; if STATE-DIRECTORY is not #f, it must be a string containing the +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." - ;; Currently this is implemented by calling out to the fine C++ blob. - (let ((pipe (apply open-pipe* OPEN_WRITE %guix-register-program - `(,@(if prefix - `("--prefix" ,prefix) - '()) - ,@(if state-directory - `("--state-directory" ,state-directory) - '()))))) - (and pipe - (begin - (format pipe "~a~%~a~%~a~%" - path (or deriver "") (length references)) - (for-each (cut format pipe "~a~%" <>) references) - (zero? (close-pipe pipe)))))) + (let* ((to-register (string-append %store-directory "/" (basename path)))) + (let-values (((hash nar-size) + (nar-sha256 (string-append prefix "/" to-register)))) + (sqlite-register #:dbpath (string-append state-directory "/db/db.sqlite") + #:path to-register + #:references references + #:deriver deriver + #:hash (string-append "sha256:" + (bytevector->base16-string hash)) + #:nar-size nar-size)))) ;;; -- 2.13.0