WIP

8 files changed, 283 insertions, 34 deletions

diff --git a/bin/evaluate.in b/bin/evaluate.in
index d1d0767..3918681 100644
--- a/bin/evaluate.in
+++ b/bin/evaluate.in
@@ -32,7 +32,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
              (guix store))
 
 (define* (main #:optional (args (command-line)))
-  (match args
+  (match (peek "args" args)
     ((command load-path guix-package-path cachedir specstr database)
      ;; Load FILE, a Scheme file that defines Hydra jobs.
      (let ((%user-module (make-fresh-user-module))
@@ -43,7 +43,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
         (lambda ()
           (set-current-module %user-module)
           (with-directory-excursion
-              (string-append cachedir "/" (assq-ref spec #:name))
+              (string-append cachedir "/" (assq-ref (peek "spec" spec) #:name))
             (primitive-load (assq-ref spec #:file)))))
        (with-store store
          (unless (assoc-ref spec #:use-substitutes?)
@@ -60,11 +60,15 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
          (parameterize ((%package-database database)
                         (%use-substitutes? (assoc-ref spec #:use-substitutes?)))
            (unless (string-null? guix-package-path)
-             (set-guix-package-path! guix-package-path))
+                   (set-guix-package-path! guix-package-path))
+
            ;; Call the entry point of FILE and print the resulting job sexp.
            (let* ((proc-name (assq-ref spec #:proc))
-                  (proc    (module-ref %user-module proc-name))
-                  (thunks  (proc store (assq-ref spec #:arguments)))
+                  (proc      (module-ref %user-module proc-name))
+                  (thunks    (with-directory-excursion
+                                 (string-append cachedir "/" (assq-ref (peek "spec" spec) #:name))
+
+                               (proc store (assq-ref spec #:arguments))))
                   (db      (db-open))
                   (commit  (assq-ref spec #:current-commit))
                   (eval    `((#:specification . ,(assq-ref spec #:name))
diff --git a/doc/cuirass.texi b/doc/cuirass.texi
index 2899ffb..a8d2af7 100644
--- a/doc/cuirass.texi
+++ b/doc/cuirass.texi
@@ -339,6 +339,65 @@ This text field holds the absolute directory name of the build output or
 @code{NULL} if the build failed.
 @end table
 
+@section Database State Machine
+
+
+ -> Read in and store @code{Specifications}
+
+ -> Main loop
+
+    -> Fetch @code{Specifications}
+
+    -> For each @code{Specification}
+
+       -> If a @code{Stamp} does not exist?
+
+          -> Create and store an @code{Evaluation}
+
+          -> For each job
+
+             -> Create a @code{Derivation}
+
+          -> Build all derivations for jobs
+
+          -> For each job
+
+             -> Create a @code{Build}
+
+
+Specification part
+
+ -> Loop
+
+    -> Read in and store @code{Specifications}
+
+    -> Trigger creating a @code{Evaluation} / @code{Stamp} ???
+
+Evaluation part
+
+ -> Check if an @code{Evaluation} / @code{Stamp} exists?
+
+    -> Create an @code{Evaluation} / @code{Stamp}
+
+    ...
+
+    -> Build all derivations for jobs
+
+    -> Trigger storing results
+
+Build results part
+
+ -> Check if the derivation has build?
+
+    -> Create a @code{Build}
+
+
+
+The database contains the following tables: @code{Specifications},
+@code{Stamps}, @code{Evaluations}, @code{Derivations}, and
+@code{Builds}.  The purpose of each of these tables is explained below.
+
+
 
 @c *********************************************************************
 @node Contributing
diff --git a/examples/gnu-system.scm b/examples/gnu-system.scm
index 4076786..bc20f25 100644
--- a/examples/gnu-system.scm
+++ b/examples/gnu-system.scm
@@ -200,7 +200,8 @@ valid."
                   (case subset
                     ((all)
                      ;; Build everything, including replacements.
-                     (let ((pkgs (fold-packages
+                     (let ((pkgs (fold-packages-in-modules
+                                  (all-modules "")
                                   (lambda (package result)
                                     (if (package-replacement package)
                                         (cons* package
diff --git a/examples/govuk-jobs.scm b/examples/govuk-jobs.scm
new file mode 100644
index 0000000..8010e5d
--- /dev/null
+++ b/examples/govuk-jobs.scm
@@ -0,0 +1,34 @@
+;;; guix-jobs.scm -- job specification test for Guix
+;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
+;;;
+;;; This file is part of Cuirass.
+;;;
+;;; Cuirass is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; Cuirass is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Cuirass.  If not, see <http://www.gnu.org/licenses/>.
+
+(define (local-file file)
+  ;; In the common case jobs will be defined relative to the repository.
+  ;; However for testing purpose use local gnu-system.scm instead.
+  (string-append (dirname (current-filename)) "/" file))
+
+(list
+ `((#:name . "govuk-guix")
+   (;;#:url . "https://github.com/alphagov/govuk-guix.git")
+    #:url . "/home/chris/Projects/GDS/govuk/govuk-guix")
+   ;;(#:load-path . ".")
+   (;;#:file . ,(local-file "govuk-packages.scm"))
+    #:evaluate . "./guix-pre-inst-env guile ./bin/cuirass-jobs")
+   ;;(#:proc . gov.uk-jobs)
+   (#:branch . "dev")
+   (#:one-shot? . #t)
+   (#:no-compile? . #t)))
diff --git a/examples/govuk-packages.scm b/examples/govuk-packages.scm
new file mode 100644
index 0000000..31cb2ee
--- /dev/null
+++ b/examples/govuk-packages.scm
@@ -0,0 +1,132 @@
+;;;; gnu-system.scm - build jobs for Guix
+;;;
+;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
+;;;
+;;; This file is part of Cuirass.
+;;;
+;;; Cuirass is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; Cuirass is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Cuirass.  If not, see <http://www.gnu.org/licenses/>.
+
+;; Attempt to use Guix modules from git repository.
+(eval-when (compile load eval)
+  ;; Ignore any available .go, and force recompilation.  This is because our
+  ;; checkout in the store has mtime set to the epoch, and thus .go files look
+  ;; newer, even though they may not correspond.
+  (set! %fresh-auto-compile #t))
+
+(use-modules (guix config)
+             (guix store)
+             (guix grafts)
+             (guix packages)
+             (guix derivations)
+             (guix discovery)
+             (guix monads)
+             ((guix licenses)
+              #:select (gpl3+ license-name license-uri license-comment))
+             ((guix utils) #:select (%current-system))
+             ((guix scripts system) #:select (read-operating-system))
+             (gnu packages)
+             (gnu packages commencement)
+             (gnu packages guile)
+             (gnu packages make-bootstrap)
+             (gnu system)
+             (gnu system vm)
+             (gnu system install)
+             (srfi srfi-1)
+             (ice-9 match))
+
+(define (license->alist lcs)
+  "Return LCS <license> object as an alist."
+  ;; Sometimes 'license' field is a list of licenses.
+  (if (list? lcs)
+      (map license->alist lcs)
+      `((name . ,(license-name lcs))
+        (uri . ,(license-uri lcs))
+        (comment . ,(license-comment lcs)))))
+
+(define (package-metadata package)
+  "Convert PACKAGE to an alist suitable for Hydra."
+  `((#:description . ,(package-synopsis package))
+    (#:long-description . ,(package-description package))
+    (#:license . ,(license->alist (package-license package)))
+    (#:home-page . ,(package-home-page package))
+    (#:maintainers . ("bug-guix@gnu.org"))
+    (#:max-silent-time . ,(or (assoc-ref (package-properties package)
+                                         'max-silent-time)
+                              3600))      ;1 hour by default
+    (#:timeout . ,(or (assoc-ref (package-properties package) 'timeout)
+                      72000))))           ;20 hours by default
+
+(define (package-job store job-name package system)
+  "Return a job called JOB-NAME that builds PACKAGE on SYSTEM."
+  (lambda ()
+    `((#:job-name . ,(string-append (symbol->string job-name) "." system))
+      (#:derivation . ,(derivation-file-name
+                        (parameterize ((%graft? #f))
+                          (package-derivation store package system
+                                              #:graft? #f))))
+      ,@(package-metadata package))))
+
+(define %job-name
+  ;; Return the name of a package's job.
+  (compose string->symbol package-full-name))
+
+(define package->job
+  (let ((base-packages
+         (delete-duplicates
+          (append-map (match-lambda
+                       ((_ package _ ...)
+                        (match (package-transitive-inputs package)
+                          (((_ inputs _ ...) ...)
+                           inputs))))
+                      %final-inputs))))
+    (lambda (store package system)
+      "Return a job for PACKAGE on SYSTEM, or #f if this combination is not
+valid."
+      (cond ((member package base-packages)
+             #f)
+            ((supported-package? package system)
+             (package-job store (%job-name package) package system))
+            (else
+             #f)))))
+
+(define (fold-packages-in-modules modules proc init)
+  "Call (PROC PACKAGE RESULT) for each available package within any of the
+modules in MODULES, using INIT as the initial value of RESULT.  It is
+guaranteed to never traverse the same package twice."
+  (fold-module-public-variables (lambda (object result)
+                                  (if (and (package? object)
+                                           (not (hidden-package? object)))
+                                      (proc object result)
+                                      result))
+                                init
+                                modules))
+
+(define (gov.uk-jobs store arguments)
+  (peek "getcwd" (getcwd))
+  (parameterize ((%graft? #f))
+    (let ((pkgs (fold-packages-in-modules
+                 (all-modules (list
+                               (string-append
+                                (getcwd)
+                                "/.guix-package-path")))
+                 cons
+                 '())))
+      (peek "getcwd" (getcwd))
+      (peek "pkgs" pkgs)
+      (exit 1)
+      (filter-map (lambda (pkg)
+                    (package->job store pkg system))
+                  (peek "pkgs" pkgs)))))
+
diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index 00b58f6..c986d37 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -129,6 +129,7 @@ directory and the sha1 of the top level commit in this directory."
         (tag    (and=> (assq-ref spec #:tag)
                        (lambda (t)
                          `(tag . ,t)))))
+    (peek "FETCHING LATEST " url)
     (latest-repository-commit store url
                               #:cache-directory (%package-cachedir)
                               #:ref (or branch commit tag))))
@@ -159,26 +160,32 @@ directory and the sha1 of the top level commit in this directory."
 
 (define (evaluate store db spec)
   "Evaluate and build package derivations.  Return a list of jobs."
-  (let* ((port (open-pipe* OPEN_READ
-                           "evaluate"
-                           (string-append (%package-cachedir) "/"
-                                          (assq-ref spec #:name) "/"
-                                          (assq-ref spec #:load-path))
-                           (%guix-package-path)
-                           (%package-cachedir)
-                           (object->string spec)
-                           (%package-database)))
-         (jobs (match (read port)
-                 ;; If an error occured during evaluation report it,
-                 ;; otherwise, suppose that data read from port are
-                 ;; correct and keep things going.
-                 ((? eof-object?)
-                  (raise (condition
-                          (&evaluation-error
-                           (name (assq-ref spec #:name))))))
-                 (data data))))
-    (close-pipe port)
-    jobs))
+  (with-directory-excursion
+      (string-append (%package-cachedir) "/"
+                     (assq-ref spec #:name))
+    (let* ((command (or (string-split
+                         (assq-ref (peek "spec" spec) #:evaluate)
+                         #\space)
+                        (list "evaluate"
+                              (string-append (%package-cachedir) "/"
+                                             (assq-ref spec #:name) "/"
+                                             (assq-ref spec #:load-path))
+                              (%guix-package-path)
+                              (%package-cachedir)
+                              (object->string spec)
+                              (%package-database))))
+           (port (apply open-pipe* OPEN_READ command))
+           (jobs (match (peek "RESULT: " (read port))
+                        ;; If an error occured during evaluation report it,
+                        ;; otherwise, suppose that data read from port are
+                        ;; correct and keep things going.
+                        ((? eof-object?)
+                         (raise (condition
+                                 (&evaluation-error
+                                  (name (assq-ref spec #:name))))))
+                        (data data))))
+      (close-pipe port)
+      jobs)))
 
 (define (build-packages store db jobs)
   "Build JOBS and return a list of Build results."
@@ -219,6 +226,14 @@ directory and the sha1 of the top level commit in this directory."
   ;; database potentially long after things have been built.
   (map register jobs))
 
+(define (store-jobs db jobs)
+  (for-each (lambda (job)
+              (eval-id (db-add-evaluation db eval)))
+
+              )
+            jobs))
+
+
 (define (process-specs db jobspecs)
   "Evaluate and build JOBSPECS and store results in DB."
   (define (process spec)
@@ -232,8 +247,8 @@ directory and the sha1 of the top level commit in this directory."
              (set-tls-certificate-locations! certs)))
          (receive (checkout commit)
              (fetch-repository store spec)
-           (when commit
-             (unless (string=? commit stamp)
+           (when (peek "COMMIT " commit)
+             (unless (string=? commit (peek "STAMP" stamp))
                (copy-repository-cache checkout spec)
 
                (unless (assq-ref spec #:no-compile?)
@@ -250,10 +265,12 @@ directory and the sha1 of the top level commit in this directory."
                           (format #t "Failed to evaluate ~s specification.~%"
                                   (evaluation-error-spec-name c))
                           #f))
-                 (let* ((spec* (acons #:current-commit commit spec))
+                 (let* ((spec* (peek "spec*" (acons #:current-commit commit spec)))
                         (jobs  (evaluate store db spec*)))
+                   (eval-id (db-add-evaluation db eval)))
+
                    (build-packages store db jobs))))
-             (db-add-stamp db spec commit)))))))
+             (db-add-stamp db spec commit))
 
   (for-each process jobspecs))
 
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index 31f78b1..f58a788 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -115,11 +115,11 @@ database object."
 (define (db-add-specification db spec)
   "Store specification SPEC in database DB and return its ID."
   (apply sqlite-exec db "\
-INSERT OR IGNORE INTO Specifications (repo_name, url, load_path, file, \
+INSERT OR IGNORE INTO Specifications (repo_name, url, evaluate, load_path, file, \
                   proc, arguments, branch, tag, revision, no_compile_p) \
-  VALUES ('~A', '~A', '~A', '~A', '~S', '~S', '~A', '~A', '~A', ~A);"
+  VALUES ('~A', '~A', '~A', '~A', '~A', '~S', '~S', '~A', '~A', '~A', ~A);"
          (append
-          (assq-refs spec '(#:name #:url #:load-path #:file #:proc #:arguments))
+          (assq-refs spec '(#:name #:url #:evaluate #:load-path #:file #:proc #:arguments))
           (assq-refs spec '(#:branch #:tag #:commit) "NULL")
           (list (if (assq-ref spec #:no-compile?) "1" "0"))))
   (last-insert-rowid db))
@@ -129,11 +129,12 @@ INSERT OR IGNORE INTO Specifications (repo_name, url, load_path, file, \
              (specs '()))
     (match rows
       (() specs)
-      ((#(name url load-path file proc args branch tag rev no-compile?)
+      ((#(name url evaluate load-path file proc args branch tag rev no-compile?)
         . rest)
        (loop rest
              (cons `((#:name . ,name)
                      (#:url . ,url)
+                     (#:evaluate . ,evaluate)
                      (#:load-path . ,load-path)
                      (#:file . ,file)
                      (#:proc . ,(with-input-from-string proc read))
diff --git a/src/schema.sql b/src/schema.sql
index 329d89d..5cdd8c6 100644
--- a/src/schema.sql
+++ b/src/schema.sql
@@ -3,6 +3,7 @@ BEGIN TRANSACTION;
 CREATE TABLE Specifications (
   repo_name     TEXT NOT NULL PRIMARY KEY,
   url           TEXT NOT NULL,
+  evaluate      TEXT NOT NULL,
   load_path     TEXT NOT NULL,
   file          TEXT NOT NULL,
   proc          TEXT NOT NULL,