Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 340 lines (292 sloc) 12.935 kB
5ab6c7a @mario-goulart first stab at generating feeds
authored
1 (import irregex)
2 (use atom rfc3339 ports files posix salmonella salmonella-log-parser setup-api)
3
a6bcf3b @mario-goulart Custom feeds support
authored
4 (define ok "[ok]")
5 (define fail "[fail]")
6
7
5ab6c7a @mario-goulart first stab at generating feeds
authored
8 (define (rfc3339-now)
9 (let* ((now (seconds->local-time (current-seconds)))
10 ($ (lambda (pos) (vector-ref now pos))))
11 (rfc3339->string (make-rfc3339 (+ ($ 5) 1900)
12 (+ ($ 4) 1)
13 ($ 3)
14 ($ 2)
15 ($ 1)
16 ($ 0)
17 0
18 0))))
19
a6bcf3b @mario-goulart Custom feeds support
authored
20
5ab6c7a @mario-goulart first stab at generating feeds
authored
21 (define (feed-id egg #!optional action)
22 (sprintf "tests.call-cc.org:salmonella:~a:~a:~a~a"
23 egg
24 (or action "egg")
25 (current-seconds)
26 (current-milliseconds)))
27
28
29 (define (report-link egg section salmonella-report-uri)
30 (make-link
31 uri: (make-pathname (list salmonella-report-uri section)
32 (symbol->string egg)
33 "html")))
34
35
36 (define (egg-feed egg log feeds-dir feeds-web-dir feeds-server salmonella-report-uri)
37 (write-atom-doc
38 (make-atom-doc
39 (make-feed
40 title: (make-title (sprintf "~a egg -- Salmonella report" egg))
41 authors: (list (make-author name: "salmonella-feeds"))
42 updated: (rfc3339-now)
43 id: (feed-id egg)
44 links: (list (make-link uri: (make-pathname
45 (list feeds-server feeds-web-dir)
46 (symbol->string egg)
47 "xml")))
48 generator: (make-generator
49 "salmonella-feeds"
50 uri: "http://wiki.call-cc.org/egg/salmonella-feeds")
51 entries: (append
52 (list
53 ;; Installation
54 (make-entry
55 id: (feed-id egg 'install)
56 title: (make-title
57 (sprintf "Installation status: ~a"
58 (let ((status (install-status egg log)))
59 (if (and status (zero? status))
60 ok
61 fail))))
62 updated: (rfc3339-now)
63 published: (rfc3339-now)
64 links: (list (report-link egg
65 "install"
66 salmonella-report-uri)))
67 ;; Test
68 (make-entry
69 id: (feed-id egg 'test)
70 title: (make-title
71 (sprintf "Test status: ~a"
72 (let ((status (test-status egg log)))
73 (if (and status (zero? status))
74 ok
75 fail))))
76 updated: (rfc3339-now)
77 published: (rfc3339-now)
78 links: (list (report-link egg
79 "test"
80 salmonella-report-uri))))
81 ;; Warnings
82 (filter-map
83 (lambda (entry)
84 (let ((action (report-action entry)))
85 (and (memq action '(check-dependencies
86 check-category
87 check-license
88 check-author))
89 (eq? (report-egg entry) egg)
90 (make-entry
91 id: (feed-id egg (conc "warning:" action))
92 title: (make-title
93 (sprintf "Warning: ~a" (report-message entry)))
94 updated: (rfc3339-now)
95 published: (rfc3339-now)
96 links: (list
97 (make-link
98 uri: salmonella-report-uri))))))
99 log))))))
100
101
102 (define (write-egg-feeds! log-file feeds-dir feeds-web-dir feeds-server salmonella-report-uri)
103 (let ((log (read-log-file log-file)))
104 (for-each
105 (lambda (egg)
106 (with-output-to-file (make-pathname feeds-dir (symbol->string egg) "xml")
107 (lambda ()
108 (egg-feed egg log feeds-dir feeds-web-dir feeds-server salmonella-report-uri))))
109 (log-eggs log))))
110
111
5abad8f @mario-goulart custom feeds: don't report test status for wggs whose installation fa…
authored
112 (define (custom-install-entry egg status ignore log salmonella-report-uri)
113 (if (and status (zero? status))
114 '()
115 (list
116 (make-entry
117 id: (feed-id egg 'custom-install)
118 title: (make-title
119 (sprintf "~a's installation status: ~a" egg fail))
120 updated: (rfc3339-now)
121 published: (rfc3339-now)
122 links: (list (report-link egg "install" salmonella-report-uri))))))
a6bcf3b @mario-goulart Custom feeds support
authored
123
124
125 (define (custom-test-entry egg ignore log salmonella-report-uri)
126 (if (memq 'ignore-tests ignore)
127 '()
128 (let ((status (test-status egg log)))
3cd5597 @mario-goulart custom feeds: don't report test status for eggs that don't have tests…
authored
129 (if (and status
130 (or (eq? status -1) ;; no test
131 (zero? status))) ;; test ok
a6bcf3b @mario-goulart Custom feeds support
authored
132 '()
133 (list
134 (make-entry
135 id: (feed-id egg 'custom-test)
136 title: (make-title (sprintf "~a's test status: ~a" egg fail))
137 updated: (rfc3339-now)
138 published: (rfc3339-now)
139 links: (list (report-link egg "test" salmonella-report-uri))))))))
140
141
142 (define (custom-warnings-entry egg ignore log salmonella-report-uri)
143 (if (memq 'ignore-warnings ignore)
144 '()
145 (filter-map
146 (lambda (entry)
147 (let ((action (report-action entry)))
148 (and (memq action '(check-dependencies
149 check-category
150 check-license
151 check-author))
152 (eq? (report-egg entry) egg)
153 (make-entry
154 id: (feed-id egg (conc "custom-warning:" action))
155 title: (make-title
156 (sprintf "Warning: ~a" (report-message entry)))
157 updated: (rfc3339-now)
158 published: (rfc3339-now)
159 links: (list (make-link uri: salmonella-report-uri))))))
160 log)))
161
162
163 (define (custom-feed custom-conf-file log custom-feeds-dir custom-feeds-web-dir feeds-server salmonella-report-uri)
164 (let ((config-data (handle-exceptions exn
165 #f
166 (read-file custom-conf-file))))
167 (if (and config-data (not (null? config-data)))
168 (let ((title (and-let* ((value (alist-ref 'title config-data)))
169 (car value)))
170 (eggs (filter-map (lambda (config-item)
171 (and (eq? (car config-item) 'egg)
172 (cdr config-item)))
173 config-data))
174 (custom-file (pathname-file custom-conf-file)))
175 (write-atom-doc
176 (make-atom-doc
177 (make-feed
178 title: (make-title
179 (or title
180 (string-append "Salmonella custom feed for "
181 custom-conf-file)))
182 authors: (list (make-author name: custom-file))
183 updated: (rfc3339-now)
184 id: (feed-id custom-file 'custom)
185 links: (list (make-link uri: (make-pathname
186 (list feeds-server
187 custom-feeds-web-dir)
188 custom-file
189 "xml")))
190 generator: (make-generator
191 "salmonella-feeds"
192 uri: "http://wiki.call-cc.org/egg/salmonella-feeds")
193 entries: (fold
194 (lambda (egg/ignore k)
195 (let ((egg (if (pair? egg/ignore)
196 (car egg/ignore)
197 egg/ignore))
198 (ignore (if (pair? egg/ignore)
199 (cdr egg/ignore)
200 '())))
5abad8f @mario-goulart custom feeds: don't report test status for wggs whose installation fa…
authored
201 (let ((status (install-status egg log)))
202 (append
203 (custom-install-entry egg status ignore log salmonella-report-uri)
204 (if (and status (zero? status))
205 (custom-test-entry egg ignore log salmonella-report-uri)
206 '())
207 (custom-warnings-entry egg ignore log salmonella-report-uri)
208 k))))
a6bcf3b @mario-goulart Custom feeds support
authored
209 '()
210 eggs))))))
211 ""))
212
213
0207cc0 @mario-goulart Added --custom-feeds-out-dir command line option
authored
214 (define (write-custom-feeds! log-file custom-feeds-dir custom-feeds-web-dir custom-feeds-out-dir
215 feeds-server salmonella-report-uri)
216 (unless (directory-exists? custom-feeds-out-dir)
217 (create-directory custom-feeds-out-dir 'with-parents))
a6bcf3b @mario-goulart Custom feeds support
authored
218 (let ((log (read-log-file log-file)))
219 (for-each
220 (lambda (custom-conf-file)
0207cc0 @mario-goulart Added --custom-feeds-out-dir command line option
authored
221 (with-output-to-file (make-pathname custom-feeds-out-dir
a6bcf3b @mario-goulart Custom feeds support
authored
222 (pathname-file custom-conf-file)
223 "xml")
224 (lambda ()
0207cc0 @mario-goulart Added --custom-feeds-out-dir command line option
authored
225 (custom-feed custom-conf-file log custom-feeds-dir
226 custom-feeds-web-dir feeds-server salmonella-report-uri))))
a6bcf3b @mario-goulart Custom feeds support
authored
227 (glob (make-pathname custom-feeds-dir "*.scm")))))
228
229
5ab6c7a @mario-goulart first stab at generating feeds
authored
230 (define (cmd-line-arg option args)
231 ;; Returns the argument associated to the command line option OPTION
232 ;; in ARGS or #f if OPTION is not found in ARGS or doesn't have any
233 ;; argument.
234 (let ((val (any (lambda (arg)
235 (irregex-match
236 `(seq ,(->string option) "=" (submatch (* any)))
237 arg))
238 args)))
239 (and val (irregex-match-substring val 1))))
240
241
242 (define (die . msg)
243 (with-output-to-port (current-error-port)
244 (lambda ()
245 (for-each display msg)
246 (newline)
247 (flush-output)))
248 (exit 1))
249
250
251 (define (create-dir dir)
252 (unless (directory-exists? dir)
253 (when (file-exists? dir)
254 (die dir " is a file."))
255 (parameterize ((setup-verbose-mode #f)
256 (run-verbose #f))
257 (create-directory/parents dir))))
258
259
260 (define (usage #!optional exit-code)
261 (let ((this (pathname-strip-directory (program-name))))
262 (display #<#EOF
263 #this [ -h | --help ]
264 #this <options>
265
266 <options>:
267
268 --log-file=<file>
269 The salmonella log file.
270
271 --feeds-dir=<dir>
a6bcf3b @mario-goulart Custom feeds support
authored
272 Directory where to write feed files.
273
274 --custom-feeds-dir=<dir>
275 Directory where custom feeds can be read from (optional).
5ab6c7a @mario-goulart first stab at generating feeds
authored
276
0207cc0 @mario-goulart Added --custom-feeds-out-dir command line option
authored
277 --custom-feeds-out-dir=<dir>
278 Directory where custom feeds will be written to.
279
5ab6c7a @mario-goulart first stab at generating feeds
authored
280 --feeds-web-dir=<dir>
281 The web directory (i.e., the directory which HTTP clients request) where
282 feeds are located.
283
a6bcf3b @mario-goulart Custom feeds support
authored
284 --custom-feeds-web-dir=<dir>
285 The web directory (i.e., the directory which HTTP clients request) where
286 custom feeds are located.
287
5ab6c7a @mario-goulart first stab at generating feeds
authored
288 --feeds-server=<server address>
289 Feeds server address (e.g., "http://tests.call-cc.org")
290
291 --salmonella-report-uri=<URI>
292 The URI where salmonella reports can be located.
293 EOF
294 )
295 (newline)
296 (when exit-code (exit exit-code))))
297
298
299 (let ((args (command-line-arguments)))
300
301 (when (or (member "-h" args)
302 (member "--help" args))
303 (usage 0))
304
305 (when (null? args)
306 (usage 1))
307
308 (let ((log-file (cmd-line-arg '--log-file args))
309 (feeds-dir (or (cmd-line-arg '--feeds-dir args)
310 (die "Missing --feeds-dir=<dir>")))
a6bcf3b @mario-goulart Custom feeds support
authored
311 (custom-feeds-dir (cmd-line-arg '--custom-feeds-dir args))
5ab6c7a @mario-goulart first stab at generating feeds
authored
312 (feeds-web-dir (or (cmd-line-arg '--feeds-web-dir args)
313 (die "Missing --feeds-web-dir=<dir>")))
a6bcf3b @mario-goulart Custom feeds support
authored
314 (custom-feeds-web-dir (cmd-line-arg '--custom-feeds-web-dir args))
0207cc0 @mario-goulart Added --custom-feeds-out-dir command line option
authored
315 (custom-feeds-out-dir (cmd-line-arg '--custom-feeds-out-dir args))
5ab6c7a @mario-goulart first stab at generating feeds
authored
316 (feeds-server (or (cmd-line-arg '--feeds-server args)
317 (die "Missing --feeds-server=<server address>")))
318 (salmonella-report-uri
319 (or (cmd-line-arg '--salmonella-report-uri args)
320 (die "Missing --salmonella-report-uri=<URI>"))))
321
322 (create-dir feeds-dir)
323
a6bcf3b @mario-goulart Custom feeds support
authored
324 (when custom-feeds-dir
325 (create-dir custom-feeds-dir))
326
0207cc0 @mario-goulart Added --custom-feeds-out-dir command line option
authored
327 (when (and custom-feeds-dir custom-feeds-out-dir custom-feeds-web-dir)
a6bcf3b @mario-goulart Custom feeds support
authored
328 (write-custom-feeds! log-file
329 custom-feeds-dir
330 custom-feeds-web-dir
0207cc0 @mario-goulart Added --custom-feeds-out-dir command line option
authored
331 custom-feeds-out-dir
a6bcf3b @mario-goulart Custom feeds support
authored
332 feeds-server
333 salmonella-report-uri))
334
335 (write-egg-feeds! log-file
336 feeds-dir
337 feeds-web-dir
338 feeds-server
339 salmonella-report-uri)))
Something went wrong with that request. Please try again.