blob: ae201d1a877b4cc384e8e2f982ea7f93796b9a93 (
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
|
#!/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] [CACHEDIR]" (%program-name))
(display "
Run Guix job from a git repository cloned in CACHEDIR.
-f --use-file=FILE Use FILE which defines the job to evaluate
-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
`((file (single-char #\f) (value #t))
(database (single-char #\f) (value #t))
(interval (single-char #\I) (value #t))
(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 cachedir spec)
"Get the latest version of Guix repository. Clone repository in directory
DIR if required."
(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! cachedir 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 cachedir name path) "/")))
(format #t "prepending ~s to the load path~%" dir)
(set! %load-path (cons dir %load-path))))
(define (evaluate store db cachedir spec)
"Evaluate and build package derivations. Return a list a jobs."
(save-module-excursion
(lambda ()
(set-current-module %user-module)
;; Handle both relative and absolute file names for SPEC-FILE.
(with-directory-excursion cachedir
(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)))
(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 (lambda (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)))
;;;
;;; Entry point.
;;;
(define* (main #:optional (args (command-line)))
(let ((opts (getopt-long args %options)))
(parameterize
((%program-name (car args))
(%package-database (option-ref opts 'database (%package-database))))
(cond
((option-ref opts 'help #f)
(show-help)
(exit 0))
((option-ref opts 'version #f)
(show-version)
(exit 0))
(else
(let* ((specfile (option-ref opts 'file "tests/hello-subset.scm"))
(interval (option-ref opts 'interval "60"))
(specs (primitive-load specfile))
(args (option-ref opts '() #f))
(cachedir (if (null? args)
(getenv "CUIRASS_CACHEDIR")
(car args))))
(with-database db
(while #t
(for-each
(λ (spec)
(fetch-repository cachedir spec)
(let ((old-path %load-path))
(and (job-spec-load-path spec)
(set-load-path! cachedir spec))
(let ((store ((guix-variable 'store 'open-connection))))
(dynamic-wind
(const #t)
(lambda ()
(let ((jobs (evaluate store db cachedir spec))
(set-build-options
(guix-variable 'store 'set-build-options)))
(set-build-options store #:use-substitutes? #f)
(build-packages store db jobs)))
(lambda ()
((guix-variable 'store 'close-connection) store)
(set! %load-path old-path))))))
specs)
(sleep (string->number interval))))))))))
|