source: project/release/4/salmonella/trunk/salmonella @ 15097

Last change on this file since 15097 was 15097, checked in by Ivan Raikov, 10 years ago

salmonella parameter repository-data is now renamed to egg-information

File size: 15.7 KB
Line 
1#!/bin/sh
2#| -*- scheme -*-
3exec csi -s $0 "$@"
4|#
5
6(use setup-download utils posix (srfi 1 13))
7
8(define chicken-install (make-parameter "chicken-install"))
9(define lib-dir (make-pathname '("lib" "chicken") "4"))
10(define repo-test-dir (make-parameter (make-pathname (current-directory) "salmonella-repo")))
11(define repo-test-lib-dir (make-parameter (make-pathname (repo-test-dir) lib-dir)))
12(define chicken-install-args (make-parameter (lambda () (string-append " -prefix " (repo-test-dir)))))
13
14(define env-vars      (make-parameter (string-append
15                                       "CHICKEN_INSTALL_PREFIX=" (repo-test-dir)
16                                       " "
17                                       "CHICKEN_INCLUDE_PATH=" (repo-test-lib-dir))))
18(define skip-eggs     (make-parameter '()))
19(define verbose       (make-parameter #f))
20(define logfile       (make-parameter "salmonella.log"))
21(define system-deps   (make-parameter #f))
22(define pkg-manager   (make-parameter #f))
23(define resume        (make-parameter #f))
24(define dont-ask      (make-parameter #f))
25(define progress-file (make-parameter "salmonella.progress"))
26(define html-output   (make-parameter "salmonella-report"))
27(define css-file      (make-parameter #f))
28(define ->html        (make-parameter #f))
29
30(define (show . msg)
31  (when (verbose)
32    (print "  " (string-concatenate (map ->string msg)))))
33
34(define egg-information (make-parameter (lambda () #f)))
35
36(define eggs (make-parameter (lambda () #f)))
37
38(define (system:system . command)
39  ;; I'm afraid this thing won't work on windows...
40  (let* ((p (open-input-pipe (sprintf "~A 2>&1" (string-concatenate command))))
41         (output (read-all p)))
42    (values (close-input-pipe p) output)))
43
44(define (system:output . command)
45  (let-values (((status output) (system:system (string-concatenate command))))
46    output))
47
48(define (system:status . command)
49  (let-values (((status output) (system:system (string-concatenate command))))
50    status))
51
52(define usage
53  "Usage: salmonella -h | -help | --help | -?
54          salmonella <conf-file>
55          salmonella <options>
56
57<options> are Scheme expressions. <conf-file> is a file which may
58contain the same Scheme expressions as <options>'s. The following
59expressions are recognized:
60
61             == Expression ==                   == Default ==
62 (chicken-install \"<path to chicken-install>\")    chicken-install
63 (chicken-install-args \"<args>\"                 a procedure which returns chicken-install options
64 (env-vars \"<environment variables settings>\" CHICKEN_INCLUDE_PATH=(repo-test-lib-dir)
65                                                CHICKEN_INSTALL_PREFIX=(repo-test-dir)
66 (repo-test-dir \"<path to repo-test-dir>\")    `pwd`/salmonella-repo
67 (skip-eggs (list \"egg1\" \"egg2\" ...))         '()
68 (verbose <bool>)                             #f
69 (logfile \"filename\")                         salmonella.log
70 (egg-information (lambda () ...))              a procedure which returns egg information for all eggs found in ./chicken-eggs
71 (eggs (lambda () ...))                         a procedure which returns the names of all eggs found in ./chicken-eggs
72 (system-deps \"filename\")                     #f
73 (pkg-manager \"system pkg manager & args\")    #f
74 (resume <bool>)                              #f
75 (dont-ask <bool>)                            #f
76 (progress-file \"filename\")                   salmonella.progress
77 (dont-ask <bool>)                            #f
78 (progress-file \"filename\")                   salmonella.progress
79 (html-output \"dirname\")                      salmonella-report.  If #f, no HTML output
80 (css-file \"filename\")                        #f
81 (->html \"filename\")                          #f
82Example:
83
84 salmonella '(chicken-install \"/usr/local/chicken/bin/chicken-install\") (verbose #t)'
85")
86
87(define (delete-path . paths)
88  ;; mostly stolen from chicken-setup.scm
89  (define *windows*
90    (and (eq? (software-type) 'windows)
91         (build-platform) ) )
92
93  (define *windows-shell* (memq *windows* '(msvc mingw32)))
94  (let ((cmd (if *windows-shell* "del /Q /S" "rm -fr")))
95    (for-each (lambda (path) (system* "~a ~a" cmd path)) paths)))
96
97(define (clean-repo-test-dir)
98  (delete-path (make-pathname (repo-test-dir) "*")))
99
100(define (delete-eggs-source #!optional confirm)
101  (when confirm
102    (display (string-append "salmonella will delete all *.egg and *.egg-dir files and directories under "
103                            (current-directory) ".  Proceed? [y/n]: "))
104    (flush-output)
105    (unless (string=? (read-line) "y")
106      (print "Aborting.")
107      (exit 0)))
108  (delete-path (make-pathname (current-directory) "*.egg")
109               (make-pathname (current-directory) "*.egg-dir")))
110
111(define (install-egg egg)
112  (system:system (sprintf"~a ~a ~a ~a" (env-vars) (chicken-install) ((chicken-install-args)) egg)))
113
114(define (report egg status msg #!key (action 'egg-install))
115  (with-output-to-file (logfile)
116    (lambda () (pp (list egg action status msg))) append:))
117
118(define (set-installed egg)
119  (with-output-to-file (progress-file) (cut print egg) append:))
120
121(define (current-time) (seconds->string (current-seconds)))
122
123(define (report-env)
124  (when (logfile)
125    (with-output-to-file (logfile)
126      (lambda ()
127        (pp #<#EOF
128salmonella -- a tool for testing Chicken eggs (http://chicken.wiki.br/salmonella)
129#(string-trim-both (current-time))
130#(system:output (chicken-install) " -version")
131Options:
132  chicken-install: #(chicken-install)
133  repo-test-dir: #(repo-test-dir)
134  chicken-install-args: #((chicken-install-args))
135  env-vars: #(env-vars)
136  skip-eggs:  #(skip-eggs)
137  verbose: #(verbose)
138  logfile: #(logfile)
139  pkg-manager: #(pkg-manager)
140  system-deps: #(system-deps)
141  resume: #(resume)
142  dont-ask: #(dont-ask)
143  progress-file: #(progress-file)
144  html-output: #(html-output)
145  css-file: #(css-file)
146  ->html: #(->html)
147EOF
148)))))
149
150(define (install-system-deps egg dep-table)
151  (let ((deps (assq (string->symbol egg) dep-table)))
152    (when deps
153      (for-each
154       (lambda (dep)
155         (show "Installing system dependency " dep)
156         (let-values (((status output) (system:system (pkg-manager) egg)))
157           (report egg status output action: 'osdep-install)))
158       (map ->string (cdr deps))))))
159
160(define (create-directory-recursively dir)
161  (let ((done '()))
162    (for-each (lambda (d)
163                (let ((to-create (make-pathname done d)))
164                  (if (directory? to-create)
165                      'skip
166                      (unless (string-null? to-create)
167                        (create-directory to-create)))
168                  (set! done (append done (list d)))))
169              (let* ((sep (->string ##sys#pathname-directory-separator))
170                     (dirs (string-split dir sep)))
171                (if (absolute-pathname? dir)
172                    (cons sep dirs)
173                    dirs)))))
174
175(define (create-repo-test-dir)
176  (create-directory-recursively (repo-test-lib-dir)))
177
178(define egg-dependencies
179  (let ((eggs/deps '()))
180    (lambda arg
181      (when (null? eggs/deps)
182        (set! eggs/deps (map (lambda (egg-data)
183                               (cons (car egg-data) (drop egg-data 3)))
184                             ((egg-information)))))
185      (if (null? arg)
186          eggs/deps
187          (let ((egg (car arg)))
188            (alist-ref (if (string? egg)
189                           (string->symbol egg)
190                           egg)
191                       eggs/deps))))))
192
193(define (main)
194  (let ((args (command-line-arguments)))
195   
196    ;; Check if user is asking for help
197    (unless (null? args)
198      (when (member (car args) '("-h" "-help" "--help" "-?"))
199        (print usage)
200        (exit 0)))
201   
202    ;; Eval command line options
203    (if (and (not (null? args)) (file-exists? (car args)))
204        (load (car args))
205        (for-each eval (with-input-from-string (string-intersperse args) read-file)))
206
207    (unless ((eggs))
208      (eggs (lambda ()
209              (show "Fetching eggs list...")
210              (map (compose ->string car) ((egg-information))))))
211
212    (unless ((egg-information))
213      (egg-information
214       (let ((egg-data #f))
215         (lambda () (if (not egg-data)
216                        (set! egg-data (gather-egg-information "chicken-eggs"))
217                        egg-data)))))
218   
219    (when (->html)
220      (logfile (->html))
221      (report->html)
222      (exit 0))
223         
224    (if (resume)
225        (if (file-exists? (progress-file))
226            (skip-eggs (append (skip-eggs) (read-lines (progress-file))))
227            (begin
228              (print "Could not find progress-file " (progress-file))
229              (exit 1)))
230        (when (file-exists? (progress-file))
231          (delete-file (progress-file))))
232   
233    (clean-repo-test-dir)
234    (unless (directory? (repo-test-dir))
235      (create-repo-test-dir))
236    (report-env)
237
238    (delete-eggs-source (not (dont-ask)))
239   
240    (let ((deps (and (pkg-manager) (system-deps) (read-file (system-deps))))
241          (successful '())
242          (fail '()))
243      (for-each (lambda (egg)
244                  (unless (member egg (skip-eggs))
245                    (install-system-deps egg deps)
246                    (show "Deleting " egg " egg source (if exists)...")
247                    (delete-eggs-source)
248                    (display (string-append "Installing " egg))
249                    (flush-output)
250                    (let-values (((status output) (install-egg egg)))
251                      (print (string-pad
252                              (cond ((zero? status)
253                                     (set! successful (cons egg successful))
254                                     "[ok]")
255                                    (else (set! fail (cons egg fail))
256                                          "[error]"))
257                              (- 50 (string-length egg))))
258                      (when (logfile) (report egg status output)))
259                    (set-installed egg)
260                    (show "Cleaning up " (repo-test-dir) "...")
261                    (clean-repo-test-dir)))
262                ((eggs))))))
263
264(define css-data
265"body { font-size: 10pt; }
266#egg-even { background-color: #CCC; }
267#egg-fail { font-weight: bold; color: red; }
268#egg-ok { font-weight: bold; color: blue; }
269#egg-odd { background-color: #FFFFCC; }")
270 
271;;; A simple web-scheme replacement
272
273(define s+ string-append)
274
275(define (make-tag tagname)
276  (lambda (data #!key (id #f))
277    (conc "<" tagname (if id (conc " id=\"" id "\"") "") ">"
278          data
279          "</" tagname ">")))
280
281(define (a url text)
282  (s+ "<a 'href='" url "'>" text "</a>"))
283
284(define p (make-tag 'p))
285(define div (make-tag 'div))
286(define pre (make-tag 'pre))
287(define td (make-tag 'td))
288(define tr (make-tag 'tr))
289(define table (make-tag 'table))
290(define b (make-tag 'b))
291(define html (make-tag 'html))
292(define body (make-tag 'body))
293(define head (make-tag 'head))
294(define title (make-tag 'title))
295(define meta (make-tag 'meta))
296(define style (make-tag 'style))
297(define h1 (make-tag 'h1))
298(define h2 (make-tag 'h2))
299(define h3 (make-tag 'h3))
300
301(define (ws:page contents #!key (css #f) (page-title ""))
302  (html
303   (s+ (head (s+ (title page-title)
304                 (if css
305                     (s+ "<link rel=stylesheet href='" css "' type=text/css>")
306                     "")))
307       (body contents))))
308
309(define (tag-attribs->string attribs)
310  (string-intersperse (map (lambda (attrib)
311                             (conc (car attrib) "=\"" (cdr attrib) "\""))
312                           attribs)
313                      " "))
314
315(define alternate-odd/even
316  (let ((current #f))
317    (lambda ()
318      (set! current (not current))
319      (if current
320          'egg-even
321          'egg-odd))))
322   
323(define (ws:make-table alist)
324  (table (string-intersperse
325          (map (lambda (line)
326                 (tr (string-intersperse (map td line) "") id: (alternate-odd/even)))
327               alist) "")))
328
329(define (report->html)
330
331  (define (link-egg-doc egg)
332    (a (conc "http://www.call-with-current-continuation.org/eggs/" egg ".html")
333       "egg page"))
334
335  (define (link-egg-deps egg)
336    (a (conc "http://chicken.wiki.br/dep-graphs/" egg ".png")
337       "dependencies"))
338
339  (define (egg-fail? egg eggs)
340    (let ((egg-data (alist-ref (->string egg) eggs equal?)))
341      ;; some eggs are not explicitly tested, so have no status
342      (and egg-data (not (zero? (cadr egg-data))))))
343         
344  ;; if the optional argument FAIL is not #f, it indicates that all the EGGS failed
345  (define (tabularize-eggs eggs css #!optional fail)
346    (ws:make-table
347     (append
348      (list (map b (let ((h '("Egg" "Date" "Doc" "Dependencies")))
349                     (if fail
350                         (append h (list "Broken dependencies"))
351                         h))))
352      (map (lambda (egg-data)
353             (let ((egg (car egg-data))
354                   (status (caddr egg-data))
355                   (output (cadddr egg-data)))
356               ;; write the per-egg report
357               (with-output-to-file (make-pathname (html-output) egg ".html")
358                 (lambda ()
359                   (print (ws:page (string-append (h1 egg) (pre output))
360                                   css: css
361                                   page-title: egg))))
362               ;; generate the eggs table
363               (map (lambda (info)
364                      (a (make-pathname '() egg ".html") info))
365                    (let ((data
366                           (list egg
367                                 (let ((egg-data (alist-ref (string->symbol egg) ((egg-information)))))
368                                   (if egg-data
369                                       (cadaar egg-data)
370                                       ""))
371                                 (link-egg-doc egg)
372                                 (link-egg-deps egg))))
373                      (if fail
374                          (append data (list (string-intersperse
375                                              (map link-egg-doc
376                                                   (filter (lambda (egg)
377                                                             (egg-fail? egg eggs))
378                                                           (egg-dependencies egg)))
379                                              ",")))
380                          data)))))
381           (sort eggs (lambda (s1 s2) (string< (car s1) (car s2))))))))
382
383  (show "Generating HTML report")
384  (when (file-exists? (html-output))
385    (delete-path (html-output)))
386  (create-directory (html-output))
387  (let* ((data (with-input-from-file (logfile) read-file))
388         (env-report (car data))
389         (eggs-report (cdr data))
390         (css (or (css-file)
391                  (begin
392                    (with-output-to-file (make-pathname (html-output) "salmonella.css")
393                      (cut print css-data))
394                    "salmonella.css"))))
395    (with-output-to-file (make-pathname (html-output) "index.html")
396      (lambda ()
397        (print
398         (ws:page
399          (string-append
400           (h1 "Salmonella report")
401           (h2 "Summary")
402           (let* ((success (filter (lambda (l) (zero? (caddr l))) eggs-report))
403                  (fail (filter (lambda (l) (not (zero? (caddr l)))) eggs-report))
404                  (success-count (length success))
405                  (fail-count (length fail))
406                  (total (+ (length eggs-report) (length (skip-eggs)))))
407             (string-append
408              (ws:make-table
409               `(("Failed"   ,(div (number->string fail-count) id: "egg-fail"))
410                 ("Succeed"  ,(div (number->string success-count) id: "egg-ok"))
411                 ("Skipped"  ,(length (skip-eggs)))
412                 (,(b "Total")    ,(b (number->string total)))))
413              (h2 "Eggs")
414              (h3 "Failed") (tabularize-eggs fail css 'fail)
415              (h3 "Succeed") (tabularize-eggs success css)
416              (if (null? (skip-eggs))
417                  ""
418                  (string-append
419                   (h3 "Skipped")
420                   (ws:make-table (append `((,(b "Egg"))) (map list (skip-eggs))))))))
421           (h2 "Environment")
422           (pre env-report)
423           (p (conc "Finished at: " (current-time))))
424          css: css
425          page-title: "Salmonella report"))))))
426
427(main)
428(when (html-output) (report->html))
Note: See TracBrowser for help on using the repository browser.