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

Last change on this file since 15098 was 15098, checked in by Ivan Raikov, 11 years ago

additional chicken-install-specific fixes to salmonella

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