02/09: guix: register-path: Honor environment variables.

[Caleb Ristvedt]

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

commit bcacbdfd21ed36e9507dad2bbf7778f0a98b3d35
Author: Caleb Ristvedt <address@hidden>
Date:   Mon Jun 5 01:34:28 2017 -0500

    guix: register-path: Honor environment variables.
    
    * guix/store.scm (register-path): Honor environment variables involving the
    store, state directory, or database path. Update copyright info.
    * guix/sql.scm: Add copyright notice.
---
 guix/sql.scm   | 18 +++++++++++++++++
 guix/store.scm | 61 +++++++++++++++++++++++++++++++++++++++++++---------------
 2 files changed, 63 insertions(+), 16 deletions(-)

diff --git a/guix/sql.scm b/guix/sql.scm
index b1e0c0a..b6153e3 100644
--- a/guix/sql.scm
+++ b/guix/sql.scm
@@ -1,3 +1,21 @@
+;;; Copyright © 2017 Caleb Ristvedt <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+
 (define-module (guix sql)
   #:use-module (sqlite3)
   #:use-module (system foreign)
diff --git a/guix/store.scm b/guix/store.scm
index a62fcf3..2f16ec2 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès 
<address@hidden>
+;;; Copyright © 2017 Caleb Ristvedt <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -1246,15 +1247,17 @@ 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...)
+;; 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 "")
-                        (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 +1267,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))))
 
 
 ;;;