source: project/salmonella/trunk/salmonella.scm @ 6950

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