Merge branch 'master' into staging

3 files changed, 205 insertions, 87 deletions

diff --git a/guix/store/database.scm b/guix/store/database.scm
index 3623c0e7a..05b2ba6c3 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -24,30 +24,76 @@
   #:use-module (guix store deduplication)
   #:use-module (guix base16)
   #:use-module (guix build syscalls)
+  #:use-module ((guix build utils)
+                #:select (mkdir-p executable-file?))
+  #:use-module (guix build store-copy)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-26)
+  #:use-module (rnrs io ports)
   #:use-module (ice-9 match)
-  #:export (sqlite-register
+  #:use-module (system foreign)
+  #:export (sql-schema
+            with-database
+            sqlite-register
             register-path
+            register-items
+            %epoch
             reset-timestamps))
 
 ;;; Code for working with the store database directly.
 
+(define sql-schema
+  ;; Name of the file containing the SQL scheme or #f.
+  (make-parameter #f))
 
-(define-syntax-rule (with-database file db exp ...)
-  "Open DB from FILE and close it when the dynamic extent of EXP... is left."
-  (let ((db (sqlite-open file)))
+(define sqlite-exec
+  ;; XXX: This is was missing from guile-sqlite3 until
+  ;; <https://notabug.org/civodul/guile-sqlite3/commit/b87302f9bcd18a286fed57b2ea521845eb1131d7>.
+  (let ((exec (pointer->procedure
+               int
+               (dynamic-func "sqlite3_exec" (@@ (sqlite3) libsqlite3))
+               '(* * * * *))))
+    (lambda (db text)
+      (let ((ret (exec ((@@ (sqlite3) db-pointer) db)
+                       (string->pointer text)
+                       %null-pointer %null-pointer %null-pointer)))
+        (unless (zero? ret)
+          ((@@ (sqlite3) sqlite-error) db "sqlite-exec" ret))))))
+
+(define (initialize-database db)
+  "Initializing DB, an empty database, by creating all the tables and indexes
+as specified by SQL-SCHEMA."
+  (define schema
+    (or (sql-schema)
+        (search-path %load-path "guix/store/schema.sql")))
+
+  (sqlite-exec db (call-with-input-file schema get-string-all)))
+
+(define (call-with-database file proc)
+  "Pass PROC a database record corresponding to FILE.  If FILE doesn't exist,
+create it and initialize it as a new database."
+  (let ((new? (not (file-exists? file)))
+        (db   (sqlite-open file)))
     (dynamic-wind noop
                   (lambda ()
-                    exp ...)
+                    (when new?
+                      (initialize-database db))
+                    (proc db))
                   (lambda ()
                     (sqlite-close db)))))
 
+(define-syntax-rule (with-database file db exp ...)
+  "Open DB from FILE and close it when the dynamic extent of EXP... is left.
+If FILE doesn't exist, create it and initialize it as a new database."
+  (call-with-database file (lambda (db) exp ...)))
+
 (define (last-insert-row-id db)
   ;; XXX: (sqlite3) currently lacks bindings for 'sqlite3_last_insert_rowid'.
   ;; Work around that.
   (let* ((stmt   (sqlite-prepare db "SELECT last_insert_rowid();"
-                               #:cache? #t))
+                                 #:cache? #t))
          (result (sqlite-fold cons '() stmt)))
     (sqlite-finalize stmt)
     (match result
@@ -85,7 +131,7 @@ of course. Returns the row id of the row that was modified or inserted."
     (if id
         (let ((stmt (sqlite-prepare db update-sql #:cache? #t)))
           (sqlite-bind-arguments stmt #:id id
-                                 #:path path #:deriver deriver
+                                 #:deriver deriver
                                  #:hash hash #:size nar-size #:time time)
           (sqlite-fold cons '() stmt)
           (sqlite-finalize stmt)
@@ -99,13 +145,11 @@ of course. Returns the row id of the row that was modified or inserted."
           (last-insert-row-id db)))))
 
 (define add-reference-sql
-  "INSERT OR IGNORE INTO Refs (referrer, reference) SELECT :referrer, id
-FROM ValidPaths WHERE path = :reference")
+  "INSERT OR REPLACE INTO Refs (referrer, reference) VALUES (:referrer, :reference);")
 
 (define (add-references db referrer references)
   "REFERRER is the id of the referring store item, REFERENCES is a list
-containing store items being referred to.  Note that all of the store items in
-REFERENCES must already be registered."
+ids of items referred to."
   (let ((stmt (sqlite-prepare db add-reference-sql #:cache? #t)))
     (for-each (lambda (reference)
                 (sqlite-reset stmt)
@@ -116,37 +160,41 @@ REFERENCES must already be registered."
                 (last-insert-row-id db))
               references)))
 
-;; XXX figure out caching of statement and database objects... later
-(define* (sqlite-register #:key db-file path (references '())
-                          deriver hash nar-size)
-  "Registers this stuff in a database specified by DB-FILE. 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-database db-file db
-    (let ((id (update-or-insert db #:path path
-                                #:deriver deriver
-                                #:hash hash
-                                #:nar-size nar-size
-                                #:time (time-second (current-time time-utc)))))
-      (add-references db id references))))
+(define* (sqlite-register db #:key path (references '())
+                          deriver hash nar-size time)
+  "Registers this stuff in DB.  PATH is the store item to register and
+REFERENCES is the list of store items PATH refers to; DERIVER is the '.drv'
+that produced PATH, HASH is the base16-encoded Nix sha256 hash of
+PATH (prefixed with \"sha256:\"), and NAR-SIZE is the size in bytes PATH after
+being converted to nar form.  TIME is the registration time to be recorded in
+the database or #f, meaning \"right now\".
+
+Every store item in REFERENCES must already be registered."
+  (let ((id (update-or-insert db #:path path
+                              #:deriver deriver
+                              #:hash hash
+                              #:nar-size nar-size
+                              #:time (time-second
+                                      (or time
+                                          (current-time time-utc))))))
+    ;; Call 'path-id' on each of REFERENCES.  This ensures we get a
+    ;; "non-NULL constraint" failure if one of REFERENCES is unregistered.
+    (add-references db id
+                    (map (cut path-id db <>) references))))
 
 
 ;;;
 ;;; High-level interface.
 ;;;
 
-;; TODO: Factorize with that in (gnu build install).
 (define (reset-timestamps file)
   "Reset the modification time on FILE and on all the files it contains, if
-it's a directory."
+it's a directory.  While at it, canonicalize file permissions."
   (let loop ((file file)
              (type (stat:type (lstat file))))
     (case type
       ((directory)
+       (chmod file #o555)
        (utime file 0 0 0 0)
        (let ((parent file))
          (for-each (match-lambda
@@ -165,24 +213,14 @@ it's a directory."
        ;; symlinks.
        #f)
       (else
+       (chmod file (if (executable-file? file) #o555 #o444))
        (utime file 0 0 0 0)))))
 
-;; 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, 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 (deduplicate? #t))
-  ;; Priority for options: first what is given, then environment variables,
-  ;; then defaults. %state-directory, %store-directory, and
-  ;; %store-database-directory already handle the "environment variables /
-  ;; defaults" question, so we only need to choose between what is given and
-  ;; those.
+                        state-directory (deduplicate? #t)
+                        (reset-timestamps? #t)
+                        (schema (sql-schema)))
   "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
@@ -192,43 +230,76 @@ 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* ((db-dir (cond
-                  (state-directory
-                   (string-append state-directory "/db"))
-                  (prefix
-                   ;; If prefix is specified, the value of NIX_STATE_DIR
-                   ;; (which affects %state-directory) isn't supposed to
-                   ;; affect db-dir, only the compile-time-customized
-                   ;; default should.
-                   (string-append prefix %localstatedir "/guix/db"))
-                  (else
-                   %store-database-directory)))
-         (store-dir (if prefix
-                        ;; same situation as above
-                        (string-append prefix %storedir)
-                        %store-directory))
-         (to-register (if prefix
-                          (string-append %storedir "/" (basename path))
-                          ;; note: we assume here that if path is, for
-                          ;; example, /foo/bar/gnu/store/thing.txt and prefix
-                          ;; isn't given, then an environment variable has
-                          ;; been used to change the store directory to
-                          ;; /foo/bar/gnu/store, since otherwise real-path
-                          ;; would end up being /gnu/store/thing.txt, which is
-                          ;; probably not the right file in this case.
-                          path))
-         (real-path (string-append store-dir "/" (basename path))))
-    (let-values (((hash nar-size)
-                  (nar-sha256 real-path)))
-      (reset-timestamps real-path)
-      (sqlite-register
-       #:db-file (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)
+  (register-items (list (store-info path deriver references))
+                  #:prefix prefix #:state-directory state-directory
+                  #:deduplicate? deduplicate?
+                  #:reset-timestamps? reset-timestamps?
+                  #:schema schema))
 
+(define %epoch
+  ;; When it all began.
+  (make-time time-utc 0 1))
+
+(define* (register-items items
+                         #:key prefix state-directory
+                         (deduplicate? #t)
+                         (reset-timestamps? #t)
+                         registration-time
+                         (schema (sql-schema)))
+  "Register all of ITEMS, a list of <store-info> records as returned by
+'read-reference-graph', in the database under PREFIX/STATE-DIRECTORY.  ITEMS
+must be in topological order (with leaves first.)  If the database is
+initially empty, apply SCHEMA to initialize it.  REGISTRATION-TIME must be the
+registration time to be recorded in the database; #f means \"now\"."
+
+  ;; Priority for options: first what is given, then environment variables,
+  ;; then defaults. %state-directory, %store-directory, and
+  ;; %store-database-directory already handle the "environment variables /
+  ;; defaults" question, so we only need to choose between what is given and
+  ;; those.
+
+  (define db-dir
+    (cond (state-directory
+           (string-append state-directory "/db"))
+          (prefix
+           (string-append prefix %localstatedir "/guix/db"))
+          (else
+           %store-database-directory)))
+
+  (define store-dir
+    (if prefix
+        (string-append prefix %storedir)
+        %store-directory))
+
+  (define (register db item)
+    (define to-register
+      (if prefix
+          (string-append %storedir "/" (basename (store-info-item item)))
+          ;; note: we assume here that if path is, for example,
+          ;; /foo/bar/gnu/store/thing.txt and prefix isn't given, then an
+          ;; environment variable has been used to change the store directory
+          ;; to /foo/bar/gnu/store, since otherwise real-path would end up
+          ;; being /gnu/store/thing.txt, which is probably not the right file
+          ;; in this case.
+          (store-info-item item)))
+
+    (define real-file-name
+      (string-append store-dir "/" (basename (store-info-item item))))
+
+    (let-values (((hash nar-size) (nar-sha256 real-file-name)))
+      (when reset-timestamps?
+        (reset-timestamps real-file-name))
+      (sqlite-register db #:path to-register
+                       #:references (store-info-references item)
+                       #:deriver (store-info-deriver item)
+                       #:hash (string-append "sha256:"
+                                             (bytevector->base16-string hash))
+                       #:nar-size nar-size
+                       #:time registration-time)
       (when deduplicate?
-        (deduplicate real-path hash #:store store-dir)))))
+        (deduplicate real-file-name hash #:store store-dir))))
+
+  (mkdir-p db-dir)
+  (parameterize ((sql-schema schema))
+    (with-database (string-append db-dir "/db.sqlite") db
+      (for-each (cut register db <>) items))))
diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm
index 4b4ac01f6..d3139eb90 100644
--- a/guix/store/deduplication.scm
+++ b/guix/store/deduplication.scm
@@ -85,7 +85,7 @@ LINK-PREFIX."
       (lambda ()
         (link target tempname)
         tempname)
-      (lambda (args)
+      (lambda args
         (if (= (system-error-errno args) EEXIST)
             (try (tempname-in link-prefix))
             (throw 'system-error args))))))
@@ -120,12 +120,15 @@ under STORE."
          (link-file       (string-append links-directory "/"
                                          (bytevector->base16-string hash))))
     (mkdir-p links-directory)
-    (if (file-is-directory? path)
+    (if (eq? 'directory (stat:type (lstat path)))
         ;; Can't hardlink directories, so hardlink their atoms.
         (for-each (lambda (file)
-                    (unless (member file '("." ".."))
-                      (deduplicate file (nar-sha256 file)
-                                   #:store store)))
+                    (unless (or (member file '("." ".."))
+                                (and (string=? path store)
+                                     (string=? file ".links")))
+                      (let ((file (string-append path "/" file)))
+                        (deduplicate file (nar-sha256 file)
+                                     #:store store))))
                   (scandir path))
         (if (file-exists? link-file)
             (false-if-system-error (EMLINK)
diff --git a/guix/store/schema.sql b/guix/store/schema.sql
new file mode 100644
index 000000000..c1b4a689a
--- /dev/null
+++ b/guix/store/schema.sql
@@ -0,0 +1,44 @@
+create table if not exists ValidPaths (
+    id               integer primary key autoincrement not null,
+    path             text unique not null,
+    hash             text not null,
+    registrationTime integer not null,
+    deriver          text,
+    narSize          integer
+);
+
+create table if not exists Refs (
+    referrer  integer not null,
+    reference integer not null,
+    primary key (referrer, reference),
+    foreign key (referrer) references ValidPaths(id) on delete cascade,
+    foreign key (reference) references ValidPaths(id) on delete restrict
+);
+
+create index if not exists IndexReferrer on Refs(referrer);
+create index if not exists IndexReference on Refs(reference);
+
+-- Paths can refer to themselves, causing a tuple (N, N) in the Refs
+-- table.  This causes a deletion of the corresponding row in
+-- ValidPaths to cause a foreign key constraint violation (due to `on
+-- delete restrict' on the `reference' column).  Therefore, explicitly
+-- get rid of self-references.
+create trigger if not exists DeleteSelfRefs before delete on ValidPaths
+  begin
+    delete from Refs where referrer = old.id and reference = old.id;
+  end;
+
+create table if not exists DerivationOutputs (
+    drv  integer not null,
+    id   text not null, -- symbolic output id, usually "out"
+    path text not null,
+    primary key (drv, id),
+    foreign key (drv) references ValidPaths(id) on delete cascade
+);
+
+create index if not exists IndexDerivationOutputs on DerivationOutputs(path);
+
+create table if not exists FailedPaths (
+    path text primary key not null,
+    time integer not null
+);