job: Add <job> record type.

* src/cuirass/job.scm: New file.
* Makefile.am (dist_pkgmodule_DATA): Add it.
* bin/cuirass.in (evaluate, build-packages): Use it.
pull/3/head
Mathieu Lirzin 2016-06-10 23:33:16 +02:00
parent d3487acc42
commit ecffeb7536
No known key found for this signature in database
GPG Key ID: 0ADEE10094604D37
3 changed files with 42 additions and 7 deletions

View File

@ -5,6 +5,7 @@ noinst_SCRIPTS = pre-inst-env
dist_pkgmodule_DATA = \
src/cuirass/base.scm \
src/cuirass/job.scm \
src/cuirass/ui.scm
nodist_pkgmodule_DATA = \

View File

@ -22,6 +22,7 @@ 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 job)
(cuirass ui)
(ice-9 getopt-long)
(ice-9 match))
@ -74,12 +75,11 @@ DIR if required."
m))
(define (build-packages store jobs)
"Build JOBS which is a list of job. ((job-symbol pair ...) ...)"
(map (lambda (thing)
(let ((name (symbol->string (car thing)))
(drv (cdadr thing)))
(format #t "building ~A => ~A~%" name drv)
((guix-variable 'derivations 'build-derivations) store (list drv))))
"Build JOBS which is a list of <job> objects."
(map (match-lambda
(($ <job> name drv)
(format #t "building ~A => ~A~%" name drv)
((guix-variable 'derivations 'build-derivations) store (list drv))))
jobs))
(define (evaluate dir spec)
@ -101,7 +101,9 @@ DIR if required."
(map (lambda (job thunk)
(format (current-error-port) "evaluating '~a'... " job)
(force-output (current-error-port))
(cons job (call-with-time-display thunk)))
(make-job (symbol->string job)
(assoc-ref (call-with-time-display thunk)
'derivation)))
names thunks)))))
(lambda ()
((guix-variable 'store 'close-connection) store)))))

32
src/cuirass/job.scm Normal file
View File

@ -0,0 +1,32 @@
;;;; job.scm - data structures for jobs
;;;
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;;
;;; This file is part of Cuirass.
;;;
;;; Cuirass is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Cuirass is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Cuirass. If not, see <http://www.gnu.org/licenses/>.
(define-module (cuirass job)
#:use-module (srfi srfi-9)
#:export (<job>
make-job
job?
job-name
job-derivation))
(define-record-type <job>
(make-job name derivation)
job?
(name job-name) ;string
(derivation job-derivation)) ;string