Change <job-spec> and <job> semantics.

4 files changed, 147 insertions, 127 deletions

diff --git a/bin/cuirass.in b/bin/cuirass.in
index bfd7168..e35655f 100644
--- a/bin/cuirass.in
+++ b/bin/cuirass.in
@@ -33,7 +33,6 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
 Run Guix job from a git repository cloned in CACHEDIR.
 
   -f  --use-file=FILE       Use FILE which defines the job to evaluate
-      --subset=SET          Evaluate SET which is a subset of Guix packages
   -I, --interval=N          Wait N seconds between each evaluation
   -V, --version             Display version
   -h, --help                Display this help message")
@@ -42,40 +41,41 @@ Run Guix job from a git repository cloned in CACHEDIR.
 
 (define %options
   `((file     (single-char #\f) (value #t))
-    (subset   (value #t))
     (interval (single-char #\I) (value #t))
     (version  (single-char #\V) (value #f))
     (help     (single-char #\h) (value #f))))
 
-(define %guix-repository
-  (make-parameter "git://git.savannah.gnu.org/guix.git"))
-
-(define* (pull-changes dir)
-  "Get the latest version of Guix repository.  Clone repository in directory
-DIR if required."
-  (or (file-exists? dir) (mkdir dir))
-  (with-directory-excursion dir
-    (let ((guixdir "guix"))
-      (or (file-exists? guixdir)
-          (system* "git" "clone" (%guix-repository) guixdir))
-      (with-directory-excursion guixdir
-        (and (zero? (system* "git" "fetch")) ;no 'git pull' to avoid merges
-             (zero? (system* "git" "reset" "--hard" "origin/master")))))))
-
-(define (compile dir)
-  "Compile files in Guix cloned repository in directory DIR."
-  (with-directory-excursion (string-append dir "/guix")
-    (or (file-exists? "configure") (system* "./bootstrap"))
-    (or (file-exists? "Makefile")
-        (system* "./configure" "--localstatedir=/var"))
-    (zero? (system* "make" "-j" (number->string (current-processor-count))))))
-
 (define %user-module
   ;; Cuirass user module.
   (let ((m (make-module)))
     (beautify-user-module! m)
     m))
 
+(define (fetch-repository cachedir spec)
+  "Get the latest version of Guix repository.  Clone repository in directory
+DIR if required."
+  (or (file-exists? cachedir) (mkdir cachedir))
+  (with-directory-excursion cachedir
+    (match spec
+      (($ <job-spec> name url branch)
+       (or (file-exists? name) (system* "git" "clone" url name))
+       (with-directory-excursion name
+         (and (zero? (system* "git" "fetch"))
+              (zero? (system* "git" "reset" "--hard"
+                              (string-append "origin/" branch)))))))))
+
+(define (evaluate store cachedir spec)
+  "Evaluate and build package derivations."
+  (save-module-excursion
+   (lambda ()
+     (set-current-module %user-module)
+     (let ((dir (string-append cachedir "/" (job-spec-name spec))))
+       (format #t "prepending ~s to the load path~%" dir)
+       (set! %load-path (cons dir %load-path)))
+     (primitive-load (job-spec-file spec))))
+  (let ((proc (module-ref %user-module (job-spec-proc spec))))
+    (proc store (job-spec-arguments spec))))
+
 (define (build-packages store jobs)
   "Build JOBS which is a list of <job> objects."
   (map (match-lambda
@@ -88,23 +88,6 @@ DIR if required."
                                   'derivation-path->output-path) drv))))
        jobs))
 
-(define (evaluate store dir spec args)
-  "Evaluate and build package derivations in directory DIR."
-  (save-module-excursion
-   (lambda ()
-     (set-current-module %user-module)
-     (let ((guixdir (string-append dir "/guix")))
-       (format #t "prepending ~s to the load path~%" guixdir)
-       (set! %load-path (cons guixdir %load-path)))
-     (primitive-load spec)))
-  (let ((job-specs ((module-ref %user-module 'hydra-jobs) store args)))
-    (map (match-lambda
-           (($ <job-spec> name thunk metadata)
-            (format (current-error-port) "evaluating '~a'... " name)
-            (force-output (current-error-port))
-            (make-job name (call-with-time-display thunk) metadata)))
-         job-specs)))
-
 
 ;;;
 ;;; Entry point.
@@ -121,24 +104,23 @@ DIR if required."
       (show-version progname)
       (exit 0))
      (else
-      (let* ((store    ((guix-variable 'store 'open-connection)))
-             (jobfile  (option-ref opts 'file "tests/gnu-system.scm"))
-             (subset   (option-ref opts 'subset "all"))
+      (let* ((specfile (option-ref opts 'file "tests/hello-subset.scm"))
+             (spec     (primitive-load specfile))
              (args     (option-ref opts '() #f))
              (cachedir (if (null? args)
                            (getenv "CUIRASS_CACHEDIR")
                            (car args))))
-        (dynamic-wind
-          (const #t)
-          (lambda ()
-            (while #t
-              (pull-changes cachedir)
-              (compile cachedir)
-              (let ((jobs (evaluate store cachedir jobfile
-                                    (acons 'subset subset '()))))
-                ((guix-variable 'store 'set-build-options) store
-                 #:use-substitutes? #f)
-                (build-packages store jobs))
-              (sleep (string->number (option-ref opts 'interval "60")))))
-          (lambda ()
-            ((guix-variable 'store 'close-connection) store))))))))
+        (while #t
+          (fetch-repository cachedir spec)
+          (let ((store ((guix-variable 'store 'open-connection))))
+            (dynamic-wind
+              (const #t)
+              (lambda ()
+                (let* ((jobs  (evaluate store 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))))
+          (sleep (string->number (option-ref opts 'interval "60")))))))))
diff --git a/src/cuirass/job.scm b/src/cuirass/job.scm
index 19e83c2..48c49b4 100644
--- a/src/cuirass/job.scm
+++ b/src/cuirass/job.scm
@@ -18,6 +18,7 @@
 ;;; along with Cuirass.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (cuirass job)
+  #:use-module (cuirass base)
   #:use-module (srfi srfi-9)
   #:export (<job>
             make-job
@@ -28,9 +29,13 @@
 
             <job-spec>
             make-job-spec
+            job-spec?
             job-spec-name
+            job-spec-url
+            job-spec-branch
+            job-spec-file
             job-spec-proc
-            job-spec-metadata))
+            job-spec-arguments))
 
 (define-record-type <job>
   (%make-job name derivation metadata)
@@ -39,15 +44,26 @@
   (derivation job-derivation)           ;string
   (metadata   job-metadata))            ;alist
 
-(define* (make-job name drv #:optional (metadata '()))
-  (%make-job name drv metadata))
+(define-syntax make-job
+  (syntax-rules ()
+    ;; XXX: Different orders for keyword/argument pairs should be allowed.
+    ((make-job #:name name #:derivation filename #:metadata metadata)
+     (begin
+       (format (current-error-port) "evaluating '~a'... " name)
+       (force-output (current-error-port))
+       (%make-job name
+                  (call-with-time-display (λ () filename))
+                  metadata)))))
 
 (define-record-type <job-spec>
-  (%make-job-spec name proc metadata)
+  (%make-job-spec name url branch file proc arguments)
   job-spec?
-  (name       job-spec-name)            ;string
-  (proc       job-spec-proc)            ;thunk
-  (metadata   job-spec-metadata))       ;alist
+  (name      job-spec-name)             ;string
+  (url       job-spec-url)              ;string
+  (branch    job-spec-branch)           ;string
+  (file      job-spec-file)             ;string
+  (proc      job-spec-proc)             ;symbol
+  (arguments job-spec-arguments))       ;alist
 
-(define* (make-job-spec #:key name procedure metadata)
-  (%make-job-spec name procedure metadata))
+(define* (make-job-spec #:key name url branch file proc arguments)
+  (%make-job-spec name url branch file proc arguments))
diff --git a/tests/gnu-system.scm b/tests/gnu-system.scm
index d58f47e..caacacd 100644
--- a/tests/gnu-system.scm
+++ b/tests/gnu-system.scm
@@ -66,33 +66,25 @@
     (timeout . ,(or (assoc-ref (package-properties package) 'timeout)
                     72000))))           ;20 hours by default
 
-(define (package-job-spec store job-name package system)
-  "Return a non evaluated job called JOB-NAME that builds PACKAGE on SYSTEM."
-  (make-job-spec
-   #:name
-   (string-append (symbol->string job-name) "." system)
-   #:procedure
-   (λ ()
-     (derivation-file-name
-      (parameterize ((%graft? #f))
-        (package-derivation store package system #:graft? #f))))
-   #:metadata
-   (package-metadata package)))
-
-(define (package-cross-job-spec store job-name package target system)
-  "Return a non evaluated job called TARGET.JOB-NAME that cross-builds PACKAGE
+(define (package-job store job-name package system)
+  "Return a job called JOB-NAME that builds PACKAGE on SYSTEM."
+  (make-job
+   #:name (string-append (symbol->string job-name) "." system)
+   #:derivation (derivation-file-name
+                 (parameterize ((%graft? #f))
+                   (package-derivation store package system #:graft? #f)))
+   #:metadata (package-metadata package)))
+
+(define (package-cross-job store job-name package target system)
+  "Return a job called TARGET.JOB-NAME that cross-builds PACKAGE
 for TARGET on SYSTEM."
-  (make-job-spec
-   #:name
-   (string-append target "." (symbol->string job-name) "." system)
-   #:procedure
-   (λ ()
-     (derivation-file-name
-      (parameterize ((%graft? #f))
-        (package-cross-derivation store package target system
-                                  #:graft? #f))))
-   #:metadata
-   (package-metadata package)))
+  (make-job
+   #:name (string-append target "." (symbol->string job-name) "." system)
+   #:derivation (derivation-file-name
+                 (parameterize ((%graft? #f))
+                   (package-cross-derivation store package target system
+                                             #:graft? #f)))
+   #:metadata (package-metadata package)))
 
 (define %core-packages
   ;; Note: Don't put the '-final' package variants because (1) that's
@@ -115,21 +107,18 @@ for TARGET on SYSTEM."
   '("mips64el-linux-gnu"
     "mips64el-linux-gnuabi64"))
 
-(define (tarball-job-specs store system)
+(define (tarball-jobs store system)
   "Return Hydra jobs to build the self-contained Guix binary tarball."
   (list
-   (make-job-spec
-    #:name
-    (string-append "binary-tarball." system)
-    #:procedure
-    (λ ()
-      (derivation-file-name
-       (parameterize ((%graft? #f))
-         (run-with-store store
-           (mbegin %store-monad
-             (set-guile-for-build (default-guile))
-             (self-contained-tarball))
-           #:system system))))
+   (make-job
+    #:name (string-append "binary-tarball." system)
+    #:derivation (derivation-file-name
+                  (parameterize ((%graft? #f))
+                    (run-with-store store
+                      (mbegin %store-monad
+                        (set-guile-for-build (default-guile))
+                        (self-contained-tarball))
+                      #:system system)))
     #:metadata
     `((description . "Stand-alone binary Guix tarball")
       (long-description . "This is a tarball containing binaries of Guix and
@@ -138,11 +127,11 @@ all its dependencies, and ready to be installed on non-GuixSD distributions.")
       (home-page . ,%guix-home-page-url)
       (maintainers . ("bug-guix@gnu.org"))))))
 
-(define job-name
+(define %job-name
   ;; Return the name of a package's job.
   (compose string->symbol package-full-name))
 
-(define package->job-spec
+(define package->job
   (let ((base-packages
          (delete-duplicates
           (append-map (match-lambda
@@ -157,7 +146,7 @@ valid."
       (cond ((member package base-packages)
              #f)
             ((supported-package? package system)
-             (package-job-spec store (job-name package) package system))
+             (package-job store (%job-name package) package system))
             (else
              #f)))))
 
@@ -195,8 +184,8 @@ valid."
 
     (append-map (lambda (target)
                   (map (lambda (package)
-                         (package-cross-job-spec store (job-name package)
-                                                 package target system))
+                         (package-cross-job store (job-name package)
+                                            package target system))
                        %packages-to-cross-build))
                 (remove (either from-32-to-64? same?) %cross-targets)))
 
@@ -207,30 +196,30 @@ valid."
                   (case subset
                     ((all)
                      ;; Build everything, including replacements.
-                     (let ((all (fold-packages
-                                 (lambda (package result)
-                                   (if (package-replacement package)
-                                       (cons* package
-                                              (package-replacement package)
-                                              result)
-                                       (cons package result)))
-                                 '()))
-                           (job (lambda (package)
-                                  (package->job-spec store package system))))
-                       (append (filter-map job all)
-                               (tarball-job-specs store system)
+                     (let ((pkgs (fold-packages
+                                  (lambda (package result)
+                                    (if (package-replacement package)
+                                        (cons* package
+                                               (package-replacement package)
+                                               result)
+                                        (cons package result)))
+                                  '())))
+                       (append (filter-map (lambda (pkg)
+                                             (package->job store pkg system))
+                                           pkgs)
+                               (tarball-jobs store system)
                                (cross-jobs system))))
                     ((core)
                      ;; Build core packages only.
                      (append (map (lambda (package)
-                                    (package-job-spec store (job-name package)
-                                                      package system))
+                                    (package-job store (job-name package)
+                                                 package system))
                                   %core-packages)
                              (cross-jobs system)))
                     ((hello)
                      ;; Build hello package only.
                      (if (string=? system (%current-system))
-                         (list (package-job-spec store (job-name hello) hello system))
+                         (list (package-job store (%job-name hello) hello system))
                          '()))
                     (else
                      (error "unknown subset" subset))))
diff --git a/tests/hello-subset.scm b/tests/hello-subset.scm
new file mode 100644
index 0000000..3330142
--- /dev/null
+++ b/tests/hello-subset.scm
@@ -0,0 +1,33 @@
+;;;; hello-subset.scm - job specification test for hello subset.
+;;;
+;;; 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/>.
+
+(use-modules (cuirass job))
+
+;; In the common case jobs will be defined relative to the repository.
+;; However for testing purpose use local gnu-system.scm instead.
+(define (local-file file)
+  (string-append (dirname (current-filename)) "/" file))
+
+(make-job-spec
+ #:name "guix"
+ #:url "git://git.savannah.gnu.org/guix.git"
+ #:branch "master"
+ #:file (local-file "gnu-system.scm")
+ #:proc 'hydra-jobs
+ #:arguments '((subset . "hello")))