mirror of https://notabug.org/mthl/cuirass.git
base: Use inner definitions instead of big anonymous procedures.
* src/cuirass/base.scm (build-packages, process-specs): Use an inner definition instead of a big anonymous procedure.pull/3/head
parent
bfd395c09f
commit
5898e6f8f8
|
@ -123,52 +123,54 @@ if required."
|
|||
|
||||
(define (build-packages store db jobs)
|
||||
"Build JOBS and return a list of Build results."
|
||||
(map (λ (job)
|
||||
(let* ((name (assq-ref job #:job-name))
|
||||
(drv (assq-ref job #:derivation))
|
||||
(eval-id (assq-ref job #:eval-id))
|
||||
(success? #t)
|
||||
(error-log (string-append (%package-cachedir) "/"
|
||||
name ".log")))
|
||||
(simple-format #t "building ~A...\n" drv)
|
||||
(let ((log (call-with-output-string
|
||||
(λ (port)
|
||||
(parameterize ((current-build-output-port port))
|
||||
(catch 'srfi-34
|
||||
(λ ()
|
||||
(build-derivations store (list drv)))
|
||||
(λ (key . args)
|
||||
(set! success? #f)
|
||||
(pk "kets key:" key "args:" args))))))))
|
||||
(when (not success?)
|
||||
(with-output-to-file error-log
|
||||
(lambda () (display log)))
|
||||
(simple-format #t "build failed: ~a\n" error-log))
|
||||
(let* ((output (and success? (derivation-path->output-path drv)))
|
||||
(log (if success? (log-file store output) error-log))
|
||||
(build `((#:derivation . ,drv)
|
||||
(#:eval-id . ,eval-id)
|
||||
(#:log . ,log)
|
||||
(#:output . ,output))))
|
||||
(db-add-build db build)
|
||||
(simple-format #t "~A\n" output)
|
||||
build))))
|
||||
jobs))
|
||||
(define (build job)
|
||||
(let* ((name (assq-ref job #:job-name))
|
||||
(drv (assq-ref job #:derivation))
|
||||
(eval-id (assq-ref job #:eval-id))
|
||||
(success? #t)
|
||||
(error-log (string-append (%package-cachedir) "/"
|
||||
name ".log")))
|
||||
(simple-format #t "building ~A...\n" drv)
|
||||
(let ((log (call-with-output-string
|
||||
(λ (port)
|
||||
(parameterize ((current-build-output-port port))
|
||||
(catch 'srfi-34
|
||||
(λ ()
|
||||
(build-derivations store (list drv)))
|
||||
(λ (key . args)
|
||||
(set! success? #f)
|
||||
(pk "kets key:" key "args:" args))))))))
|
||||
(when (not success?)
|
||||
(with-output-to-file error-log
|
||||
(λ () (display log)))
|
||||
(simple-format #t "build failed: ~a\n" error-log))
|
||||
(let* ((output (and success? (derivation-path->output-path drv)))
|
||||
(log (if success? (log-file store output) error-log))
|
||||
(build `((#:derivation . ,drv)
|
||||
(#:eval-id . ,eval-id)
|
||||
(#:log . ,log)
|
||||
(#:output . ,output))))
|
||||
(db-add-build db build)
|
||||
(simple-format #t "~A\n" output)
|
||||
build))))
|
||||
|
||||
(map 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)
|
||||
(unless (assq-ref spec #:no-compile?)
|
||||
(compile (string-append (%package-cachedir) "/"
|
||||
(assq-ref spec #:name))))
|
||||
(with-store store
|
||||
(let* ((spec* (acons #:current-commit commit spec))
|
||||
(jobs (evaluate store db spec*)))
|
||||
(unless (%use-substitutes?)
|
||||
(set-build-options store #:use-substitutes? #f))
|
||||
(build-packages store db jobs))))
|
||||
(db-add-stamp db spec commit)))
|
||||
jobspecs))
|
||||
(define (process spec)
|
||||
(let ((commit (fetch-repository spec))
|
||||
(stamp (db-get-stamp db spec)))
|
||||
(unless (string=? commit stamp)
|
||||
(unless (assq-ref spec #:no-compile?)
|
||||
(compile (string-append (%package-cachedir) "/"
|
||||
(assq-ref spec #:name))))
|
||||
(with-store store
|
||||
(let* ((spec* (acons #:current-commit commit spec))
|
||||
(jobs (evaluate store db spec*)))
|
||||
(unless (%use-substitutes?)
|
||||
(set-build-options store #:use-substitutes? #f))
|
||||
(build-packages store db jobs))))
|
||||
(db-add-stamp db spec commit)))
|
||||
|
||||
(for-each process jobspecs))
|
||||
|
|
Loading…
Reference in New Issue