blob: 04d439b0d63b7ed3a02d65772f94d0c1026b51fe (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
|
#!/bin/sh
# -*- scheme -*-
exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
!#
;;;; cuirass - continuous integration system
;;;
;;; 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/>.
(use-modules (cuirass config)
(cuirass base)
(cuirass database)
(cuirass job)
(cuirass ui)
(cuirass utils)
(ice-9 getopt-long))
(define* (show-help)
(simple-format #t "Usage: ~a [OPTIONS] SPECFILE~%" (%program-name))
(display "Run build jobs from SPECFILE.
--one-shot Evaluate and build jobs only once
--cache-directory=DIR Use DIR for storing repository data
-D --database=DB Use DB to store build results.
-I, --interval=N Wait N seconds between each evaluation
-V, --version Display version
-h, --help Display this help message")
(newline)
(show-package-information))
(define %options
'((one-shot (value #f))
(cache-directory (value #t))
(database (single-char #\D) (value #t))
(interval (single-char #\I) (value #t))
(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."
(let ((cachedir (%package-cachedir)))
(or (file-exists? cachedir) (mkdir cachedir))
(with-directory-excursion cachedir
(let ((name (job-spec-name spec))
(url (job-spec-url spec))
(branch (job-spec-branch spec))
(commit (job-spec-commit spec))
(tag (job-spec-tag spec)))
(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))))))))))
(define (set-load-path! spec)
"Set %LOAD-PATH to match what is specified in SPEC."
(let* ((name (job-spec-name spec))
(path (job-spec-load-path spec))
(dir (string-join (list (%package-cachedir) name path) "/")))
(format #t "prepending ~s to the load path~%" dir)
(set! %load-path (cons dir %load-path))))
(define (evaluate store db spec)
"Evaluate and build package derivations. Return a list a 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."
(let ((build-derivations (guix-variable 'derivations 'build-derivations))
(current-build-output-port
(guix-variable 'store 'current-build-output-port))
(derivation-path->output-path
(guix-variable 'derivations 'derivation-path->output-path)))
(map (λ (job)
(let ((log-port (tmpfile))
(name (job-name job))
(drv (job-derivation job)))
(setvbuf log-port _IOLBF)
(format #t "building ~A...~%" drv)
(parameterize ((current-build-output-port log-port))
(build-derivations store (list drv))
(db-add-build-log db job log-port)
(close-port log-port))
(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))
(when (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.
;;;
(define* (main #:optional (args (command-line)))
(let* ((opts (getopt-long args %options))
(specfile (option-ref opts '() '())))
(parameterize
((%program-name (car args))
(%package-database (option-ref opts 'database (%package-database)))
(%package-cachedir
(option-ref opts 'cache-directory (%package-cachedir))))
(cond
((option-ref opts 'help #f)
(show-help)
(exit 0))
((option-ref opts 'version #f)
(show-version)
(exit 0))
((null? specfile)
(display "You must provide a specification file as argument.~%")
(exit 1))
(else
(let ((one-shot? (option-ref opts 'one-shot #f))
(interval (string->number (option-ref opts 'interval "60")))
(specs (save-module-excursion
(λ ()
(set-current-module (make-user-module))
(primitive-load (car specfile))))))
(with-database db
(if one-shot?
(process-specs db specs)
(while #t
(process-specs db specs)
(sleep interval))))))))))
|