From 5ff38984e8a0b26bf3b97477158f55b3721ee2da Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Sun, 26 Jun 2016 18:40:31 +0200 Subject: Make %package-database a parameter object. Move it to (cuirass database). --- .dir-locals.el | 5 +++- bin/cuirass.in | 53 +++++++++++++++++++------------------- src/cuirass/config.scm.in | 6 ++--- src/cuirass/database.scm | 65 ++++++++++++++++++++++++++++++----------------- tests/database.scm | 51 ++++++++++++++++++++----------------- 5 files changed, 103 insertions(+), 77 deletions(-) diff --git a/.dir-locals.el b/.dir-locals.el index e631745..29c6c99 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -8,4 +8,7 @@ (bug-reference-url-format . "http://bugs.gnu.org/%s") (bug-reference-bug-regexp . ""))) - (scheme-mode . ((indent-tabs-mode . nil)))) + (scheme-mode + . + ((indent-tabs-mode . nil) + (eval . (put 'with-database 'scheme-indent-function 1))))) diff --git a/bin/cuirass.in b/bin/cuirass.in index 87dd0ad..a998654 100644 --- a/bin/cuirass.in +++ b/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"))))))))))) diff --git a/src/cuirass/config.scm.in b/src/cuirass/config.scm.in index 8ef9d3e..361ccd8 100644 --- a/src/cuirass/config.scm.in +++ b/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@") diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm index 9143deb..8da36b5 100644 --- a/src/cuirass/database.scm +++ b/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.") diff --git a/tests/database.scm b/tests/database.scm index bdf0050..8c6efc0 100644 --- a/tests/database.scm +++ b/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 (make-parameter #t)) -(define %id (make-parameter #t)) - -(dynamic-wind - (const #t) - (λ () - (test-assert "db-init" - (%db (db-init tmp-database))) - - (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-close" - (db-close (%db)))) - (λ () - (delete-file tmp-database))) +(define %db + ;; Global Slot for a database object. + (make-parameter #t)) + +(define %id + ;; Global Slot for a job ID in the database. + (make-parameter #t)) + +(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-get-evaluation" + (db-get-evaluation (%db) (%id))) + + (test-assert "db-close" + (db-close (%db)))) + (λ () + (delete-file (%package-database))))) -- cgit v1.2.3