Store build logs in the database.

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 <job> objects."
-  (map (match-lambda
-         (($ <job> 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))))
     (λ ()