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

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

an improvement to salmonella: compare installed egg version with declared egg version

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