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.

2 files changed, 97 insertions, 91 deletions

diff --git a/bin/cuirass.in b/bin/cuirass.in
index 92a0426..ff2cc90 100644
--- a/bin/cuirass.in
+++ b/bin/cuirass.in
@@ -21,15 +21,10 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
 ;;; along with Cuirass.  If not, see <http://www.gnu.org/licenses/>.
 
 (use-modules (cuirass base)
-             (cuirass config)
              (cuirass database)
              (cuirass ui)
              (cuirass utils)
-             (guix derivations)
-             (guix store)
-             (ice-9 getopt-long)
-             (ice-9 popen)
-             (ice-9 rdelim))
+             (ice-9 getopt-long))
 
 (define (show-help)
   (format #t "Usage: ~a [OPTIONS]~%" (%program-name))
@@ -55,91 +50,6 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
     (version        (single-char #\V) (value #f))
     (help           (single-char #\h) (value #f))))
 
-(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))
-
 
 ;;;
 ;;; Entry point.
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))