diff options
| -rw-r--r-- | bin/cuirass.in | 92 | ||||
| -rw-r--r-- | src/cuirass/base.scm | 96 |
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)) |