guix-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

01/17: guix: register-path: Implement prototype in scheme.


From: Caleb Ristvedt
Subject: 01/17: guix: register-path: Implement prototype in scheme.
Date: Tue, 29 Aug 2017 02:07:47 -0400 (EDT)

reepca pushed a commit to branch guile-daemon
in repository guix.

commit 36cc9710239ccefa94c08ec0c3fde92c052b7fb2
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.
---
 gnu/packages/package-management.scm |   3 +-
 guix/sql.scm                        | 224 ++++++++++++++++++++++++++++++++++++
 guix/store.scm                      |  78 ++++++++++---
 3 files changed, 286 insertions(+), 19 deletions(-)

diff --git a/gnu/packages/package-management.scm 
b/gnu/packages/package-management.scm
index d9ea657..a42605f 100644
--- a/gnu/packages/package-management.scm
+++ b/gnu/packages/package-management.scm
@@ -252,7 +252,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 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 2563d26..e0b392a 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
@@ -1300,32 +1303,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))))
 
 
 ;;;



reply via email to

[Prev in Thread] Current Thread [Next in Thread]