From 3931c76154d4f418d5ea9acc5e47bf911d371c24 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Mon, 4 Jun 2018 15:40:09 +0200
Subject: database: 'with-database' can now initialize new databases.

* nix/libstore/schema.sql: Rename to...
* guix/store/schema.sql: ... this.
* Makefile.am (nobase_dist_guilemodule_DATA): Add it.
* nix/local.mk (%D%/libstore/schema.sql.hh): Adjust accordingly.
* guix/store/database.scm (sql-schema): New variable.
(sqlite-exec, initialize-database, call-with-database): New procedures.
(with-database): Rewrite in terms of 'call-with-database'.
* tests/store-database.scm ("new database"): New test.
* guix/self.scm (compiled-guix)[*core-modules*]: Add 'schema.sql' to
 #:extra-files.
---
 guix/store/database.scm | 50 ++++++++++++++++++++++++++++++++++++++++++++-----
 guix/store/schema.sql   | 44 +++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 89 insertions(+), 5 deletions(-)
 create mode 100644 guix/store/schema.sql

(limited to 'guix/store')

diff --git a/guix/store/database.scm b/guix/store/database.scm
index 3623c0e7a0..e81ab3dc99 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -24,25 +24,65 @@
   #:use-module (guix store deduplication)
   #:use-module (guix base16)
   #:use-module (guix build syscalls)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-19)
+  #: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
             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.
diff --git a/guix/store/schema.sql b/guix/store/schema.sql
new file mode 100644
index 0000000000..c1b4a689af
--- /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
+);
-- 
cgit v1.2.3