[PATCH] Prototype register-path

[Caleb Ristvedt <caleb.ristvedt@cune.org>]

[-- Attachment #1: Type: text/plain, Size: 1063 bytes --]

So far I've got the main functionality of register-path working: it
successfully puts the passed information in a database (at least in my
manual tests it did), and it even puts it in the right database based on
prefix and state-directory. But there are quite a few side-effects
missing, most of them noted above register-path in store.scm. There's
deduplication, resetting timestamps and permissions and stuff (the C++
code called it "canonicalizing"), actually returning true in the case of
success like the documentation says it should, processing environment
variables, and figuring out if I should be automatically creating the
database if it doesn't exist yet.

Currently the register-path unit test fails due to being unable to open
the database for writing - the test doesn't specify a prefix or
state-directory, so it's trying to open /var/guix/db/db.sqlite, which
requires root access to open for writing. Perhaps the test is using an
environment variable or similar to specify a different database, which I
haven't implemented yet.

Comments welcome.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Implement-prototype-register-path-in-scheme.patch --]
[-- Type: text/x-patch, Size: 15592 bytes --]

From f4af8973a7b41664130b05bbe8a4069f62a087c3 Mon Sep 17 00:00:00 2001
From: Caleb Ristvedt <caleb.ristvedt@cune.org>
Date: Sat, 3 Jun 2017 02:26:05 -0500
Subject: [PATCH] Implement prototype register-path in scheme

New file and module sql.scm: mostly utility macros for sqlite-register.
---
 gnu/packages/package-management.scm |   3 +-
 guix/sql.scm                        | 219 ++++++++++++++++++++++++++++++++++++
 guix/store.scm                      |  77 ++++++++++---
 3 files changed, 280 insertions(+), 19 deletions(-)
 create mode 100644 guix/sql.scm

diff --git a/gnu/packages/package-management.scm b/gnu/packages/package-management.scm
index ceaf51b67..80ffe0a2e 100644
--- a/gnu/packages/package-management.scm
+++ b/gnu/packages/package-management.scm
@@ -249,7 +249,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..ae4a1d27d
--- /dev/null
+++ b/guix/sql.scm
@@ -0,0 +1,219 @@
+(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
+  "Gives the row id of the last inserted row in DB."
+  (let ((last-rowid (pointer->procedure
+                     int
+                     (dynamic-func "sqlite3_last_insert_rowid"
+                                   (@@ (sqlite3) libsqlite3))
+                     (list '*))))
+    (lambda (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
+  "Converts key-value pairs into sqlite bindings for a specific statement."
+  (syntax-rules ()
+    ((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
+  "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."
+  (syntax-rules ()
+    ((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
+  "Automatically closes the database once the scope of this macro is left."
+  (syntax-rules ()
+    ((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 path deriver hash nar-size (current-time))))
+     (add-references db id references))))
diff --git a/guix/store.scm b/guix/store.scm
index c94dfea95..f41856fe4 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,70 @@ 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 (string-append state-directory "/db/db.sqlite")
+                       to-register
+                       references
+                       deriver
+                       (string-append "sha256:" (bytevector->base16-string hash))
+                       nar-size))))
 
 \f
 ;;;
-- 
2.13.0