mirrors
/
cuirass
mirror of https://notabug.org/mthl/cuirass.git
1
0
Fork 0
Code Issues Releases Wiki Activity

cuirass: Move code from main to auxiliary procedures.

pull/3/head
Mathieu Lirzin 2016-07-02 22:30:17 +02:00
parent b65612c264
commit 4b53493c3b
2 changed files with 56 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
bin/cuirass.in
View File

@ -50,12 +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 %user-module
;; Cuirass user module.
(let ((m (make-module)))
(beautify-user-module! m)
m))
(define (fetch-repository spec)
"Get the latest version of repository specified in SPEC. Clone repository
if required."
@ -85,21 +79,22 @@ if required."
(define (evaluate store db spec)
"Evaluate and build package derivations. Return a list a jobs."
(save-module-excursion
(λ ()
(set-current-module %user-module)
;; Handle both relative and absolute file names for SPEC-FILE.
(with-directory-excursion
(string-append (%package-cachedir) "/" (job-spec-name spec))
(primitive-load (job-spec-file spec)))))
(let* ((proc (module-ref %user-module (job-spec-proc spec)))
(jobs (proc store (job-spec-arguments spec))))
(map (λ (job)
(let ((id (db-add-evaluation db job)))
(make-job #:name (job-name job)
#:derivation (job-derivation job)
#:metadata (acons 'id id (job-metadata job)))))
jobs)))
(let ((mod (make-user-module)))
(save-module-excursion
(λ ()
(set-current-module mod)
;; Handle both relative and absolute file names for SPEC-FILE.
(with-directory-excursion
(string-append (%package-cachedir) "/" (job-spec-name spec))
(primitive-load (job-spec-file spec)))))
(let* ((proc (module-ref mod (job-spec-proc spec)))
(jobs (proc store (job-spec-arguments spec))))
(map (λ (job)
(let ((id (db-add-evaluation db job)))
(make-job #:name (job-name job)
#:derivation (job-derivation job)
#:metadata (acons 'id id (job-metadata job)))))
jobs))))
(define (build-packages store db jobs)
"Build JOBS which is a list of <job> objects."
@ -121,6 +116,28 @@ if required."
(format #t "~A~%" (derivation-path->output-path drv))))
jobs)))
(define (process-spec db spec)
"Evaluate and build SPEC"
(fetch-repository spec)
(let ((old-path %load-path))
(and (job-spec-load-path spec) (set-load-path! spec))
(let ((store ((guix-variable 'store 'open-connection))))
(dynamic-wind
(const #t)
(λ ()
(let ((jobs (evaluate store db spec))
(set-build-options
(guix-variable 'store 'set-build-options)))
(set-build-options store #:use-substitutes? #f)
(build-packages store db jobs)))
(λ ()
((guix-variable 'store 'close-connection) store)
(set! %load-path old-path))))))
(define (process-specs db jobspecs)
"Evaluate and build JOBSPECS and store results in DB."
(for-each (λ (spec) (process-spec db spec)) jobspecs))
;;;
;;; Entry point.
@ -142,27 +159,12 @@ if required."
(exit 0))
(else
(let* ((specfile (option-ref opts 'file "tests/hello-subset.scm"))
(interval (option-ref opts 'interval "60"))
(specs (primitive-load specfile)))
(interval (string->number (option-ref opts 'interval "60")))
(specs (save-module-excursion
(λ ()
(set-current-module (make-user-module))
(primitive-load specfile)))))
(with-database db
(while #t
(for-each
(λ (spec)
(fetch-repository spec)
(let ((old-path %load-path))
(and (job-spec-load-path spec)
(set-load-path! spec))
(let ((store ((guix-variable 'store 'open-connection))))
(dynamic-wind
(const #t)
(λ ()
(let ((jobs (evaluate store db spec))
(set-build-options
(guix-variable 'store 'set-build-options)))
(set-build-options store #:use-substitutes? #f)
(build-packages store db jobs)))
(λ ()
((guix-variable 'store 'close-connection) store)
(set! %load-path old-path))))))
specs)
(sleep (string->number interval))))))))))
(process-specs db specs)
(sleep interval)))))))))

11
src/cuirass/utils.scm
View File

@ -1,6 +1,7 @@
;;;; utils.scm -- helper procedures
;;;
;;; Copyright © 2012, 2013, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;;
;;; This file is part of Cuirass.
@ -22,6 +23,7 @@
#:use-module (ice-9 match)
#:export (;; Procedures
mkdir-p
make-user-module
;; Macros.
λ*
with-directory-excursion))
@ -64,3 +66,12 @@
(λ () (chdir dir))
(λ () body ...)
(λ () (chdir init)))))
(define* (make-user-module #:optional (modules '()))
"Return a new user module with the additional MODULES loaded."
;; Module in which the machine description file is loaded.
(let ((module (make-fresh-user-module)))
(for-each (lambda (iface)
(module-use! module (resolve-interface iface)))
modules)
module))