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.
This commit is contained in:
Mathieu Lirzin
parent
d493a58823
commit
4f82aeab16
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
Loading…
Reference in New Issue