Re: [PATCH] Prototype register-path

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

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


I think I may have accidentally left some stuff out of that patch due to
being new to "git format-patch" - I did several fixups which I'm not
sure were included. Anyway, I've changed it so that register-path now
honors the NIX_* environment variables that are relevant to it, which
means it now passes "make check TESTS=tests/store.scm". Still quite a
bit more to do, mainly resetting timestamps/permissions and
deduplication.

I'm especially pleased with how the interaction between environment
variables, parameters, and defaults is now a straightforward priority
list using a cond. Said interactions were spread out across the C++
codebase using global variables (well, one global variable) and lots of
state-changing, so I feel pretty good about getting that in one place.

A question about protocol, though - should followup patches like this be
replies or new top-level posts? And how often should I send them?

Again, 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: 15596 bytes --]

From 90f250814b1456387b8b0341b1f245a1c4e05f66 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 1/7] 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 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..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


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

From 76735427c25118ce4324d286ec6a524ced8bd99d Mon Sep 17 00:00:00 2001
From: Caleb Ristvedt <caleb.ristvedt@cune.org>
Date: Sat, 3 Jun 2017 02:38:53 -0500
Subject: [PATCH 2/7] fixup! Implement prototype register-path in scheme

---
 guix/sql.scm | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/guix/sql.scm b/guix/sql.scm
index ae4a1d27d..9e3815401 100644
--- a/guix/sql.scm
+++ b/guix/sql.scm
@@ -10,13 +10,13 @@
 
 ;; 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)
+      "Gives the row id of the last inserted row in DB."
       (last-rowid ((@@ (sqlite3) db-pointer) db)))))
 
 
-- 
2.13.0


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

From 4e4636cba2d62066de64dbaa88bf23169a0ecfb5 Mon Sep 17 00:00:00 2001
From: Caleb Ristvedt <caleb.ristvedt@cune.org>
Date: Sat, 3 Jun 2017 02:41:40 -0500
Subject: [PATCH 3/7] fixup! Implement prototype register-path in scheme

---
 guix/sql.scm | 8 ++++----
 1 file changed, 4 insertions(+), 4 deletions(-)

diff --git a/guix/sql.scm b/guix/sql.scm
index 9e3815401..6d756c0a6 100644
--- a/guix/sql.scm
+++ b/guix/sql.scm
@@ -22,8 +22,8 @@
 
 ;; 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 ()
+    "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) ...)))
@@ -43,10 +43,10 @@
 ;; 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
+  (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."
-  (syntax-rules ()
     ((with-sql-statement db sql statement-var
                          ((name1 val1) (name2 val2) ...)
                          exps ...)
@@ -68,8 +68,8 @@ key-value pairs."
                        (sqlite-finalize statement-var)))))))
 
 (define-syntax with-sql-database
-  "Automatically closes the database once the scope of this macro is left."
   (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
-- 
2.13.0


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

From 2973c3695b9c6f522685a03a059815485b23f580 Mon Sep 17 00:00:00 2001
From: Caleb Ristvedt <caleb.ristvedt@cune.org>
Date: Sat, 3 Jun 2017 02:49:28 -0500
Subject: [PATCH 4/7] fixup! Implement prototype register-path in scheme

---
 guix/sql.scm   |  7 ++++++-
 guix/store.scm | 13 +++++++------
 2 files changed, 13 insertions(+), 7 deletions(-)

diff --git a/guix/sql.scm b/guix/sql.scm
index 6d756c0a6..16a379f97 100644
--- a/guix/sql.scm
+++ b/guix/sql.scm
@@ -215,5 +215,10 @@ 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))))
+                     (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 f41856fe4..a62fcf3f1 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -1267,12 +1267,13 @@ 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 (string-append state-directory "/db/db.sqlite")
-                       to-register
-                       references
-                       deriver
-                       (string-append "sha256:" (bytevector->base16-string hash))
-                       nar-size))))
+      (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))))
 
 \f
 ;;;
-- 
2.13.0


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

From dd8f345a3c0c6eff2ab9d41e8eae1b7e9c339ade Mon Sep 17 00:00:00 2001
From: Caleb Ristvedt <caleb.ristvedt@cune.org>
Date: Sat, 3 Jun 2017 03:04:12 -0500
Subject: [PATCH 5/7] fixup! Implement prototype register-path in scheme

---
 guix/sql.scm | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/guix/sql.scm b/guix/sql.scm
index 16a379f97..b1e0c0aa4 100644
--- a/guix/sql.scm
+++ b/guix/sql.scm
@@ -151,7 +151,7 @@ $deriver, narSize = $size WHERE id = $id")
   "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)
+(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,
-- 
2.13.0


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #7: 0006-Honor-environment-variables-in-guix-register.patch --]
[-- Type: text/x-patch, Size: 4217 bytes --]

From ef71a89cbd1c0d1c7663d40c4770204179100da4 Mon Sep 17 00:00:00 2001
From: Caleb Ristvedt <caleb.ristvedt@cune.org>
Date: Mon, 5 Jun 2017 01:34:28 -0500
Subject: [PATCH 6/7] Honor environment variables in guix-register

Added environment variable handling to guix-register. Additionally,
interpretation of parameters state-directory and prefix now more closely
follows the way the old implementation did it.
---
 guix/store.scm | 56 ++++++++++++++++++++++++++++++++++++++++++++------------
 1 file changed, 44 insertions(+), 12 deletions(-)

diff --git a/guix/store.scm b/guix/store.scm
index a62fcf3f1..e78cfbe41 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -1251,10 +1251,16 @@ makes a wrapper around a port which implements GET-POSITION."
 ;; Figuring out how the C++ stuff currently does it sounds like a lot of
 ;; grepping for global variables...)
 
+;; As far as I can tell there are a couple of anticipated use cases for some
+;; of these parameters: prefix is set if you want to "simulate a chroot", as
+;; far as the database is concerned. For example, you could register paths in
+;; /mnt/gnu/store using #:prefix "/mnt"
+
 (define* (register-path path
-                        #:key (references '()) deriver (prefix "")
-                        (state-directory
-                         (string-append prefix %state-directory)))
+                        #:key (references '()) deriver prefix
+                        state-directory)
+  ;; Priority for options: first what is given, then environment variables,
+  ;; then defaults.
   "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
@@ -1264,16 +1270,42 @@ 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* ((db-dir (cond
+                  (state-directory
+                   (string-append state-directory "/db"))
+                  (prefix
+                   (string-append prefix %state-directory "/db"))
+                  ((getenv "NIX_DB_DIR")
+                   (getenv "NIX_DB_DIR"))
+                  ((getenv "NIX_STATE_DIR")
+                   (string-append (getenv "NIX_STATE_DIR") "/db"))
+                  (else
+                   (string-append %state-directory "/db"))))
+         (store-dir (if prefix
+                        (string-append prefix %store-directory)
+                        (or
+                         (getenv "NIX_STORE_DIR")
+                         (getenv "NIX_STORE")
+                         %store-directory)))
+         (to-register (if prefix
+                          ;; note: we assume here that if path is, for example,
+                          ;; /foo/bar/gnu/store/thing.txt, then an environment
+                          ;; variable has been used to change the store
+                          ;; directory to /foo/bar/gnu/store.
+                          (string-append %store-directory "/" (basename path))
+                          path))
+         (real-path (string-append store-dir "/"
+                                   (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))))
+                  (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))))
 
 \f
 ;;;
-- 
2.13.0


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #8: 0007-fixup-Honor-environment-variables-in-guix-register.patch --]
[-- Type: text/x-patch, Size: 1634 bytes --]

From 15099fe2489cab4aa814844bb83f5400218c129b Mon Sep 17 00:00:00 2001
From: Caleb Ristvedt <caleb.ristvedt@cune.org>
Date: Mon, 5 Jun 2017 03:09:41 -0500
Subject: [PATCH 7/7] fixup! Honor environment variables in guix-register

---
 guix/store.scm | 14 +++++---------
 1 file changed, 5 insertions(+), 9 deletions(-)

diff --git a/guix/store.scm b/guix/store.scm
index e78cfbe41..1334822ff 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -1246,15 +1246,11 @@ makes a wrapper around a port which implements GET-POSITION."
 
 ;; 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...)
-
-;; As far as I can tell there are a couple of anticipated use cases for some
-;; of these parameters: prefix is set if you want to "simulate a chroot", as
-;; far as the database is concerned. For example, you could register paths in
-;; /mnt/gnu/store using #:prefix "/mnt"
+;; pass", whatever that involves. 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...). Also, return #t on success like the documentation says we
+;; should.
 
 (define* (register-path path
                         #:key (references '()) deriver prefix
-- 
2.13.0