cuirass: Move procedures to (cuirass base) module.

* bin/cuirass.in (fetch-repository, compile, evaluate, build-packages)
(process-specs): Move to ...
src/cuirass/base.scm: ... here.

1 files changed, 96 insertions, 0 deletions

diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index 496997a..d642b9f 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -18,10 +18,21 @@
 ;;; along with Cuirass.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (cuirass base)
+  #:use-module (cuirass database)
+  #:use-module (cuirass utils)
+  #:use-module (guix derivations)
+  #:use-module (guix store)
   #:use-module (ice-9 format)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 rdelim)
   #:use-module (srfi srfi-19)
   #:export (;; Procedures.
             call-with-time-display
+            fetch-repository
+            compile
+            evaluate
+            build-packages
+            process-specs
             ;; Parameters.
             %package-cachedir))
 
@@ -54,3 +65,88 @@ values."
                 (assq-ref result #:job-name)
                 duration)
         (acons #:duration duration result)))))
+
+(define (fetch-repository spec)
+  "Get the latest version of repository specified in SPEC.  Clone repository
+if required."
+  (define (current-commit)
+    (let* ((pipe   (open-input-pipe "git log -n1"))
+           (log    (read-string pipe))
+           (commit (cadr (string-split log char-set:whitespace))))
+      (close-pipe pipe)
+      commit))
+
+  (let ((cachedir (%package-cachedir)))
+    (or (file-exists? cachedir) (mkdir cachedir))
+    (with-directory-excursion cachedir
+      (let ((name   (assq-ref spec #:name))
+            (url    (assq-ref spec #:url))
+            (branch (assq-ref spec #:branch))
+            (commit (assq-ref spec #:commit))
+            (tag    (assq-ref spec #:tag)))
+        (or (file-exists? name) (system* "git" "clone" url name))
+        (with-directory-excursion name
+          (and (zero? (system* "git" "fetch"))
+               (zero? (system* "git" "reset" "--hard"
+                               (or tag
+                                   commit
+                                   (string-append "origin/" branch))))
+               (current-commit)))))))
+
+(define (compile dir)
+  ;; Required for fetching Guix bootstrap tarballs.
+  "Compile files in repository in directory DIR."
+  (with-directory-excursion dir
+    (or (file-exists? "configure") (system* "./bootstrap"))
+    (or (file-exists? "Makefile")
+        (system* "./configure" "--localstatedir=/var"))
+    (zero? (system* "make" "-j" (number->string (current-processor-count))))))
+
+(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))
+                           (%package-cachedir)
+                           (object->string spec)
+                           (%package-database)))
+         (jobs (read port)))
+    (close-pipe port)
+    jobs))
+
+(define (build-packages store db jobs)
+  "Build JOBS and return a list of Build results."
+  (map (λ (job)
+         (let ((log-port (%make-void-port "w0"))
+               (name     (assq-ref job #:job-name))
+               (drv      (assq-ref job #:derivation)))
+           (simple-format #t "building ~A...\n" drv)
+           (parameterize ((current-build-output-port log-port))
+             (build-derivations store (list drv))
+             (let* ((output (derivation-path->output-path drv))
+                    (log    (log-file store output))
+                    (build  `((#:derivation . ,drv)
+                              (#:log . ,log)
+                              (#:output . ,output)))
+                    (id     (db-add-build db build)))
+               (close-port log-port)
+               (simple-format #t "~A\n" output)
+               (acons #:id id build)))))
+       jobs))
+
+(define (process-specs db jobspecs)
+  "Evaluate and build JOBSPECS and store results in DB."
+  (for-each (λ (spec)
+              (let ((commit (fetch-repository spec))
+                    (stamp  (db-get-stamp db spec)))
+                (unless (string=? commit stamp)
+                  (compile (string-append (%package-cachedir) "/"
+                                          (assq-ref spec #:name)))
+                  (with-store store
+                    (let ((jobs (evaluate store db spec)))
+                      (set-build-options store #:use-substitutes? #f)
+                      (build-packages store db jobs))))
+                (db-add-stamp db spec commit)))
+            jobspecs))