Make %package-database a parameter object.

Move it to (cuirass database).

.dir-locals.el

@@ -8,4 +8,7 @@
      (bug-reference-url-format . "http://bugs.gnu.org/%s")
      (bug-reference-bug-regexp
       . "<https?://\\(debbugs\\|bugs\\)\\.gnu\\.org/\\([0-9]+\\)>")))
- (scheme-mode     . ((indent-tabs-mode . nil))))
+ (scheme-mode
+  .
+  ((indent-tabs-mode . nil)
+   (eval . (put 'with-database 'scheme-indent-function 1)))))

bin/cuirass.in

@@ -111,30 +111,29 @@ DIR if required."
       (show-version progname)
       (exit 0))
      (else
-      (let* ((specfile (option-ref opts 'file "tests/hello-subset.scm"))
-             (dbfile   (option-ref opts 'database %package-database))
-             (specs    (primitive-load specfile))
-             (args     (option-ref opts '() #f))
-             (cachedir (if (null? args)
-                           (getenv "CUIRASS_CACHEDIR")
-                           (car args))))
-        (db-close (db-init dbfile))
-        (while #t
-          (for-each
-           (λ (spec)
-             (fetch-repository cachedir spec)
-             (let ((store ((guix-variable 'store 'open-connection)))
-                   (db    (db-open dbfile)))
-               (dynamic-wind
-                 (const #t)
-                 (lambda ()
-                   (let* ((jobs (evaluate store db cachedir spec))
-                          (set-build-options
-                           (guix-variable 'store 'set-build-options)))
-                     (set-build-options store #:use-substitutes? #f)
-                     (build-packages store jobs)))
-                 (lambda ()
-                   ((guix-variable 'store 'close-connection) store)
-                   (db-close db)))))
-           specs)
-          (sleep (string->number (option-ref opts 'interval "60")))))))))
+      (parameterize ((%package-database
+                      (option-ref opts 'database (%package-database))))
+        (let* ((specfile (option-ref opts 'file "tests/hello-subset.scm"))
+               (specs    (primitive-load specfile))
+               (args     (option-ref opts '() #f))
+               (cachedir (if (null? args)
+                             (getenv "CUIRASS_CACHEDIR")
+                             (car args))))
+          (with-database db
+            (while #t
+              (for-each
+               (λ (spec)
+                 (fetch-repository cachedir spec)
+                 (let ((store ((guix-variable 'store 'open-connection))))
+                   (dynamic-wind
+                     (const #t)
+                     (lambda ()
+                       (let* ((jobs (evaluate store db cachedir spec))
+                              (set-build-options
+                               (guix-variable 'store 'set-build-options)))
+                         (set-build-options store #:use-substitutes? #f)
+                         (build-packages store jobs)))
+                     (lambda ()
+                       ((guix-variable 'store 'close-connection) store)))))
+               specs)
+              (sleep (string->number (option-ref opts 'interval "60")))))))))))

src/cuirass/config.scm.in

@@ -47,6 +47,6 @@
   ;; Define to the version of this package.
   "@PACKAGE_VERSION@")
 
-(define-public %package-database
-  ;; Define to the database file name of this package.
-  (string-append "@expanded_localstatedir@/" %package ".db"))
+(define-public %localstatedir
+  ;; Define to LOCALSTATEDIR without reference to '${prefix}'.
+  "@expanded_localstatedir@")

src/cuirass/database.scm

@@ -19,14 +19,20 @@
 
 (define-module (cuirass database)
   #:use-module (cuirass base)
+  #:use-module (cuirass config)
   #:use-module (cuirass job)
   #:use-module (sqlite3)
-  #:export (db-init
+  #:export (;; Procedures.
+            db-init
             db-open
             db-close
             db-add-evaluation
             db-get-evaluation
-            db-delete-evaluation))
+            db-delete-evaluation
+            ;; Parameters.
+            %package-database
+            ;; Macros.
+            with-database))
 
 (define (sqlite-exec db sql)
   "Wrap 'sqlite-prepare', 'sqlite-step', and 'sqlite-finalize'."
@@ -34,20 +40,24 @@
     (sqlite-step stmt)
     (sqlite-finalize stmt)))
 
-(define (db-init db-name)
-  "Open database contained in DB-NAME, to store or read jobs and builds
-informations.  DB-NAME must be a string.  SCHEMA must be some SQL statements
-initialize the database.  Return a database object."
-  (when (file-exists? db-name)
-    (format (current-error-port) "Removing leftover database ~a~%" db-name)
-    (delete-file db-name))
-  (let* ((db (sqlite-open db-name (logior SQLITE_OPEN_CREATE
-                                          SQLITE_OPEN_READWRITE))))
-    (for-each (λ (sql) (sqlite-exec db sql))
-              '("PRAGMA foreign_keys=OFF;"
-                "BEGIN TRANSACTION;"
-                "COMMIT;"
-                "
+(define %package-database
+  ;; Define to the database file name of this package.
+  (make-parameter (string-append %localstatedir "/" %package ".db")))
+
+(define (db-init)
+  "Open the database to store and read jobs and builds informations.  Return a
+database object."
+  (let ((db-name (%package-database)))
+    (when (file-exists? db-name)
+      (format (current-error-port) "Removing leftover database ~a~%" db-name)
+      (delete-file db-name))
+    (let ((db (sqlite-open db-name (logior SQLITE_OPEN_CREATE
+                                           SQLITE_OPEN_READWRITE))))
+      (for-each (λ (sql) (sqlite-exec db sql))
+                '("PRAGMA foreign_keys=OFF;"
+                  "BEGIN TRANSACTION;"
+                  "COMMIT;"
+                  "
 CREATE TABLE job_spec (
   name            text not null,
   url             text not null,
@@ -57,7 +67,7 @@ CREATE TABLE job_spec (
   arguments       text not null,
   primary key (name)
 );"
-                "
+                  "
 CREATE TABLE build (
   id              integer primary key autoincrement not null,
   job_spec        text not null,
@@ -65,13 +75,12 @@ CREATE TABLE build (
   output          text
   -- foreign key (job_spec) references job_spec(name)
 );"))
-    db))
+      db)))
 
-(define (db-open filename)
-  "Open database contained in FILENAME, to store or read jobs and builds
-informations.  Return a database object.  FILENAME must be a string corresponding
-to a valid file name."
-  (sqlite-open filename SQLITE_OPEN_READWRITE))
+(define (db-open)
+  "Open database to store or read jobs and builds informations.  Return a
+database object."
+  (sqlite-open (%package-database) SQLITE_OPEN_READWRITE))
 
 (define (db-close db)
   "Close database object DB."
@@ -103,5 +112,15 @@ to a valid file name."
   (sqlite-exec db
                (format #f "delete from build where id=~A;" id)))
 
+(define-syntax-rule (with-database db body ...)
+  "Run BODY with a connection to the database which is bound to DB in BODY."
+  (let ((db (db-init)))
+    (dynamic-wind
+      (const #t)
+      (lambda ()
+        body ...)
+      (lambda ()
+        (db-close db)))))
+
 ;; (define (db-add-build db id)
 ;;   "Store a build result corresponding to ID in database DB.")

tests/database.scm

@@ -26,26 +26,31 @@
             #:derivation (string-append name ".drv")
             #:metadata '()))
 
-(define tmp-database
-  (let ((dir (dirname (current-filename))))
-    (string-append dir "/tmp.db")))
+(define %db
+  ;; Global Slot for a database object.
+  (make-parameter #t))
 
-(define %db (make-parameter #t))
-(define %id (make-parameter #t))
+(define %id
+  ;; Global Slot for a job ID in the database.
+  (make-parameter #t))
 
-(dynamic-wind
-  (const #t)
-  (λ ()
-    (test-assert "db-init"
-      (%db (db-init tmp-database)))
+(parameterize ((%package-database
+                ;; Use an empty and temporary database for the tests.
+                (let ((dir (dirname (current-filename))))
+                  (string-append dir "/tmp.db"))))
+  (dynamic-wind
+    (const #t)
+    (λ ()
+      (test-assert "db-init"
+        (%db (db-init)))
 
-    (test-assert "db-add-evaluation"
-      (%id (db-add-evaluation (%db) (make-dummy-job))))
+      (test-assert "db-add-evaluation"
+        (%id (db-add-evaluation (%db) (make-dummy-job))))
 
-    (test-assert "db-get-evaluation"
-      (db-get-evaluation (%db) (%id)))
+      (test-assert "db-get-evaluation"
+        (db-get-evaluation (%db) (%id)))
 
-    (test-assert "db-close"
-      (db-close (%db))))
-  (λ ()
-    (delete-file tmp-database)))
+      (test-assert "db-close"
+        (db-close (%db))))
+    (λ ()
+      (delete-file (%package-database)))))