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, 1 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.