From 990c902fcc5fee54a55334247df6719b9ca6e458 Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Wed, 29 Jun 2016 16:16:48 +0200 Subject: Store build logs in the database. --- bin/cuirass.in | 46 +++++++++++++++++++++++++++++----------------- src/cuirass/database.scm | 43 ++++++++++++++++++++++++++++++++----------- tests/database.scm | 11 +++++++++-- 3 files changed, 70 insertions(+), 30 deletions(-) diff --git a/bin/cuirass.in b/bin/cuirass.in index a998654..15ca948 100644 --- a/bin/cuirass.in +++ b/bin/cuirass.in @@ -79,21 +79,33 @@ DIR if required." (primitive-load (job-spec-file spec)))) (let* ((proc (module-ref %user-module (job-spec-proc spec))) (jobs (proc store (job-spec-arguments spec)))) - (for-each (λ (job) (db-add-evaluation db job)) - jobs) - jobs)) + (map (λ (job) + (let ((id (db-add-evaluation db job))) + (make-job #:name (job-name job) + #:derivation (job-derivation job) + #:metadata (acons 'id id (job-metadata job))))) + jobs))) -(define (build-packages store jobs) +(define (build-packages store db jobs) "Build JOBS which is a list of objects." - (map (match-lambda - (($ name drv) - (format #t "building ~A...~%" drv) - ((guix-variable 'derivations 'build-derivations) - store (list drv)) - (format #t "~A~%" - ((guix-variable 'derivations - 'derivation-path->output-path) drv)))) - jobs)) + (let ((build-derivations (guix-variable 'derivations 'build-derivations)) + (current-build-output-port + (guix-variable 'store 'current-build-output-port)) + (derivation-path->output-path + (guix-variable 'derivations 'derivation-path->output-path))) + (map (lambda (job) + (let ((log-port (tmpfile)) + (name (job-name job)) + (drv (job-derivation job))) + (setvbuf log-port _IOLBF) + (format #t "building ~A...~%" drv) + ;; (build-derivations store (list drv)) + (parameterize ((current-build-output-port log-port)) + (build-derivations store (list drv)) + (db-add-build-log db job log-port) + (close-port log-port)) + (format #t "~A~%" (derivation-path->output-path drv)))) + jobs))) ;;; @@ -128,11 +140,11 @@ DIR if required." (dynamic-wind (const #t) (lambda () - (let* ((jobs (evaluate store db cachedir spec)) - (set-build-options - (guix-variable 'store 'set-build-options))) + (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))) + (build-packages store db jobs))) (lambda () ((guix-variable 'store 'close-connection) store))))) specs) diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm index 8da36b5..c5bece0 100644 --- a/src/cuirass/database.scm +++ b/src/cuirass/database.scm @@ -21,6 +21,7 @@ #:use-module (cuirass base) #:use-module (cuirass config) #:use-module (cuirass job) + ;; #:use-module (ice-9 rdelim) #:use-module (sqlite3) #:export (;; Procedures. db-init @@ -29,6 +30,7 @@ db-add-evaluation db-get-evaluation db-delete-evaluation + db-add-build-log ;; Parameters. %package-database ;; Macros. @@ -72,6 +74,7 @@ CREATE TABLE build ( id integer primary key autoincrement not null, job_spec text not null, drv text not null, + log text, output text -- foreign key (job_spec) references job_spec(name) );")) @@ -88,15 +91,15 @@ database object." (define (db-add-evaluation db job) "Store a derivation result in database DB and return its ID." - (sqlite-exec - db - (format #f "insert into build (job_spec, drv) values ('~A', '~A');" - (job-name job) - (job-derivation job))) - (let* ((stmt (sqlite-prepare db "select last_insert_rowid() from build;")) - (res (sqlite-step stmt))) - (sqlite-finalize stmt) - (vector-ref res 0))) + (sqlite-exec + db + (format #f "insert into build (job_spec, drv) values ('~A', '~A');" + (job-name job) + (job-derivation job))) + (let* ((stmt (sqlite-prepare db "select last_insert_rowid() from build;")) + (res (sqlite-step stmt))) + (sqlite-finalize stmt) + (vector-ref res 0))) (define (db-get-evaluation db id) "Retrieve a job in database DB which corresponds to ID." @@ -122,5 +125,23 @@ database object." (lambda () (db-close db))))) -;; (define (db-add-build db id) -;; "Store a build result corresponding to ID in database DB.") +(define* (read-quoted-string #:optional port) + "Read all of the characters out of PORT and return them as a SQL quoted +string." + (let loop ((chars '())) + (let ((char (read-char port))) + (cond ((eof-object? char) (list->string (reverse! chars))) + ((char=? char #\') (loop (cons* char char chars))) + (else (loop (cons char chars))))))) + +(define (db-add-build-log db job log) + "Store a build LOG corresponding to JOB in database DB." + (let ((id (assoc-ref (job-metadata job) 'id)) + (log* (cond ((string? log) log) + ((port? log) + (seek log 0 SEEK_SET) + (read-quoted-string log)) + (else #f)))) + (sqlite-exec db + (format #f "update build set log='~A' where id=~A;" + log* id)))) diff --git a/tests/database.scm b/tests/database.scm index 41cb4d6..232eab4 100644 --- a/tests/database.scm +++ b/tests/database.scm @@ -21,10 +21,10 @@ (cuirass job) (srfi srfi-64)) -(define* (make-dummy-job #:optional (name "foo")) +(define* (make-dummy-job #:optional (name "foo") #:key (metadata '())) (make-job #:name name #:derivation (string-append name ".drv") - #:metadata '())) + #:metadata metadata)) (define %db ;; Global Slot for a database object. @@ -50,6 +50,13 @@ (test-assert "db-get-evaluation" (db-get-evaluation (%db) (%id))) + (test-equal "db-add-build-log" + (let ((job (make-dummy-job #:metadata `((id . ,(%id))))) + (log-column 3)) + (db-add-build-log (%db) job "foo log") + (vector-ref (db-get-evaluation (%db) (%id)) log-column)) + "foo log") + (test-assert "db-close" (db-close (%db)))) (λ () -- cgit v1.2.3