[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
02/19: guix: register-path: Implement prototype in scheme.
From: |
guix-commits |
Subject: |
02/19: guix: register-path: Implement prototype in scheme. |
Date: |
Tue, 29 Jan 2019 14:19:49 -0500 (EST) |
reepca pushed a commit to branch guile-daemon
in repository guix.
commit fe01abe9653a2cc6dd3bd086b22d11c9576c1d3f
Author: Caleb Ristvedt <address@hidden>
Date: Sat Jun 3 02:26:05 2017 -0500
guix: register-path: Implement prototype in scheme.
* guix/store.scm (register-path): reimplement in scheme.
* guix/sql.scm: New file.
---
guix/sql.scm | 224 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
guix/store.scm | 69 ++++++++++++++++++
2 files changed, 293 insertions(+)
diff --git a/guix/sql.scm b/guix/sql.scm
new file mode 100644
index 0000000..b1e0c0a
--- /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 d079147..169e64c 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -31,6 +31,7 @@
#:use-module (guix profiling)
#:autoload (guix build syscalls) (terminal-columns)
#:use-module (rnrs bytevectors)
+ #:use-module (rnrs io ports)
#:use-module (ice-9 binary-ports)
#:use-module ((ice-9 control) #:select (let/ec))
#:use-module (srfi srfi-1)
@@ -48,6 +49,8 @@
#:use-module (ice-9 threads)
#:use-module (ice-9 format)
#:use-module (web uri)
+ #:use-module (sqlite3)
+ #:use-module (guix sql)
#:export (%daemon-socket-uri
%gc-roots-directory
%default-substitute-urls
@@ -1518,6 +1521,72 @@ 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
+ (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
+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."
+ (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))))
+
;;;
;;; Store monad.
- branch guile-daemon created (now 10b0562), guix-commits, 2019/01/29
- 07/19: guix: register-path: reset timestamps after registering., guix-commits, 2019/01/29
- 01/19: patches: honor NIX_STORE in site.py., guix-commits, 2019/01/29
- 04/19: .dir-locals.el: properly indent sql macros., guix-commits, 2019/01/29
- 08/19: guix: register-path: do deduplication., guix-commits, 2019/01/29
- 12/19: linux-container: new use-output argument., guix-commits, 2019/01/29
- 02/19: guix: register-path: Implement prototype in scheme.,
guix-commits <=
- 05/19: guix: sql.scm: split into generic and store-specific parts., guix-commits, 2019/01/29
- 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