steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

mason: send HTML e-mails; if benchmarks fail build fails

db4
Slava Pestov 2009-04-17 17:55:33 -05:00
parent 9dc7b4b95a
commit b579d32e5c
6 changed files with 115 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
extra/mason/child/child.factor
View File

@ -66,6 +66,7 @@ IN: mason.child
[ test-all-vocabs-file eval-file empty? ] [ test-all-vocabs-file eval-file empty? ]
[ help-lint-vocabs-file eval-file empty? ] [ help-lint-vocabs-file eval-file empty? ]
[ compiler-errors-file eval-file empty? ] [ compiler-errors-file eval-file empty? ]
[ benchmark-error-vocabs-file eval-file empty? ]
} 0&& ; } 0&& ;
: build-child ( -- ) : build-child ( -- )

2
extra/mason/common/common.factor
View File

@ -98,6 +98,8 @@ CONSTANT: benchmark-time-file "benchmark-time"
CONSTANT: html-help-time-file "html-help-time" CONSTANT: html-help-time-file "html-help-time"
CONSTANT: benchmarks-file "benchmarks" CONSTANT: benchmarks-file "benchmarks"
CONSTANT: benchmark-error-messages-file "benchmark-error-messages"
CONSTANT: benchmark-error-vocabs-file "benchmark-error-vocabs"
SYMBOL: status SYMBOL: status

14
extra/mason/email/email.factor
View File

@ -1,18 +1,18 @@
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. ! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces accessors combinators make smtp USING: kernel namespaces accessors combinators make smtp debugger
debugger prettyprint io io.streams.string io.encodings.utf8 prettyprint io io.streams.string io.encodings.utf8 io.files io.sockets
io.files io.sockets
mason.common mason.platform mason.config ; mason.common mason.platform mason.config ;
IN: mason.email IN: mason.email
: prefix-subject ( str -- str' ) : prefix-subject ( str -- str' )
[ "mason on " % platform % ": " % % ] "" make ; [ "mason on " % platform % ": " % % ] "" make ;
: email-status ( body subject -- ) : email-status ( body content-type subject -- )
<email> <email>
builder-from get >>from builder-from get >>from
builder-recipients get >>to builder-recipients get >>to
swap >>content-type
swap prefix-subject >>subject swap prefix-subject >>subject
swap >>body swap >>body
send-email ; send-email ;
@ -25,11 +25,11 @@ IN: mason.email
} case ; } case ;
: email-report ( -- ) : email-report ( -- )
"report" utf8 file-contents subject email-status ; "report" utf8 file-contents "text/html" subject email-status ;
: email-error ( error callstack -- ) : email-error ( error callstack -- )
[ [
"Fatal error on " write host-name print nl "Fatal error on " write host-name print nl
[ error. ] [ callstack. ] bi* [ error. ] [ callstack. ] bi*
] with-string-writer "fatal error" ] with-string-writer "text/plain" "fatal error"
email-status ; email-status ;

2
extra/mason/report/report-tests.factor
View File

@ -1,2 +1,4 @@
IN: mason.report.tests IN: mason.report.tests
USING: mason.report tools.test ; USING: mason.report tools.test ;
{ 0 0 } [ [ ] with-report ] must-infer-as

147
extra/mason/report/report.factor
View File

@ -1,74 +1,117 @@
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. ! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces debugger fry io io.files io.sockets USING: benchmark combinators.smart debugger fry io assocs
io.encodings.utf8 prettyprint benchmark mason.common io.encodings.utf8 io.files io.sockets io.streams.string kernel
mason.platform mason.config sequences ; locals mason.common mason.config mason.platform math namespaces
prettyprint sequences xml.syntax xml.writer ;
IN: mason.report IN: mason.report
: time. ( file -- ) : common-report ( -- xml )
[ write ": " write ] [ eval-file milli-seconds>time print ] bi ; target-os get
target-cpu get
: common-report ( -- ) host-name
"Build machine: " write host-name print build-dir
"CPU: " write target-cpu get print "git-id" eval-file
"OS: " write target-os get print [XML
"Build directory: " write build-dir print <h1>Build report for <->/<-></h1>
"git id: " write "git-id" eval-file print nl ; <table>
<tr><td>Build machine:</td><td><-></td></tr>
<tr><td>Build directory:</td><td><-></td></tr>
<tr><td>GIT ID:</td><td><-></td></tr>
</table>
XML] ;
: with-report ( quot -- ) : with-report ( quot -- )
[ "report" utf8 ] dip '[ common-report @ ] with-file-writer ; inline [ "report" utf8 ] dip
'[
common-report
_ call( -- xml )
[XML <html><body><-><-></body></html> XML]
pprint-xml
] with-file-writer ; inline
:: failed-report ( error file what -- )
[
error [ error. ] with-string-writer :> error
file utf8 file-contents 400 short tail* :> output
[XML
<h2><-what-></h2>
Build output:
<pre><-output-></pre>
Launcher error:
<pre><-error-></pre>
XML]
] with-report ;
: compile-failed-report ( error -- ) : compile-failed-report ( error -- )
[ "compile-log" "VM compilation failed" failed-report ;
"VM compile failed:" print nl
"compile-log" cat nl
error.
] with-report ;
: boot-failed-report ( error -- ) : boot-failed-report ( error -- )
[ "boot-log" "Bootstrap failed" failed-report ;
"Bootstrap failed:" print nl
"boot-log" 100 cat-n nl
error.
] with-report ;
: test-failed-report ( error -- ) : test-failed-report ( error -- )
"test-log" "Tests failed" failed-report ;
: timings-table ( -- xml )
{
boot-time-file
load-time-file
test-time-file
help-lint-time-file
benchmark-time-file
html-help-time-file
} [
dup utf8 file-contents milli-seconds>time
[XML <tr><td><-></td><td><-></td></tr> XML]
] map [XML <h2>Timings</h2> <table><-></table> XML] ;
: fail-dump ( heading vocabs-file messages-file -- xml )
[ eval-file ] dip over empty? [ 3drop f ] [
[ ]
[ [ [XML <li><-></li> XML] ] map [XML <ul><-></ul> XML] ]
[ utf8 file-contents ]
tri*
[XML <h1><-></h1> <-> Details: <pre><-></pre> XML]
] if ;
: benchmarks-table ( assoc -- xml )
[ [
"Tests failed:" print nl 1000000 /f
"test-log" 100 cat-n nl [XML <tr><td><-></td><td><-></td></tr> XML]
error. ] { } assoc>map [XML <h2>Benchmarks</h2> <table><-></table> XML] ;
] with-report ;
: successful-report ( -- ) : successful-report ( -- )
[ [
boot-time-file time. [
load-time-file time. timings-table
test-time-file time.
help-lint-time-file time.
benchmark-time-file time.
html-help-time-file time.
nl "Load failures"
load-everything-vocabs-file
load-everything-errors-file
fail-dump
load-everything-vocabs-file eval-file [ "Compiler warnings and errors"
"== Did not pass load-everything:" print . compiler-errors-file
load-everything-errors-file cat compiler-error-messages-file
] unless-empty fail-dump
compiler-errors-file eval-file [ "Unit test failures"
"== Vocabularies with compiler errors:" print . test-all-vocabs-file
] unless-empty test-all-errors-file
fail-dump
test-all-vocabs-file eval-file [ "Help lint failures"
"== Did not pass test-all:" print . help-lint-vocabs-file
test-all-errors-file cat help-lint-errors-file
] unless-empty fail-dump
help-lint-vocabs-file eval-file [ "Benchmark errors"
"== Did not pass help-lint:" print . benchmark-error-vocabs-file
help-lint-errors-file cat benchmark-error-messages-file
] unless-empty fail-dump
"== Benchmarks:" print "Benchmark timings"
benchmarks-file eval-file benchmarks. benchmarks-file eval-file benchmarks-table
] output>array
] with-report ; ] with-report ;

8
extra/mason/test/test.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. ! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs benchmark bootstrap.stage2 USING: accessors assocs benchmark bootstrap.stage2
compiler.errors generic help.html help.lint io.directories compiler.errors generic help.html help.lint io.directories
@ -42,7 +42,11 @@ M: method-body word-vocabulary "method-generic" word-prop word-vocabulary ;
do-step ; do-step ;
: do-benchmarks ( -- ) : do-benchmarks ( -- )
run-benchmarks benchmarks-file to-file ; run-benchmarks
[
[ keys benchmark-error-vocabs-file to-file ]
[ benchmark-error-messages-file utf8 [ benchmark-errors. ] with-file-writer ] bi
] [ benchmarks-file to-file ] bi* ;
: benchmark-ms ( quot -- ms ) : benchmark-ms ( quot -- ms )
benchmark 1000 /i ; inline benchmark 1000 /i ; inline