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

2009-04-17 17:55:33 -05:00 · 2009-04-17 17:55:33 -05:00 · b579d32e5c
parent 9dc7b4b95a
commit b579d32e5c
6 changed files with 115 additions and 63 deletions
--- a/extra/mason/child/child.factor
+++ b/extra/mason/child/child.factor
@ -66,6 +66,7 @@ IN: mason.child
        [ test-all-vocabs-file eval-file empty? ]
        [ help-lint-vocabs-file eval-file empty? ]
        [ compiler-errors-file eval-file empty? ]
+        [ benchmark-error-vocabs-file eval-file empty? ]
    } 0&& ;

 : build-child ( -- )
--- a/extra/mason/common/common.factor
+++ b/extra/mason/common/common.factor
@ -98,6 +98,8 @@ CONSTANT: benchmark-time-file "benchmark-time"
 CONSTANT: html-help-time-file "html-help-time"

 CONSTANT: benchmarks-file "benchmarks"
+CONSTANT: benchmark-error-messages-file "benchmark-error-messages"
+CONSTANT: benchmark-error-vocabs-file "benchmark-error-vocabs"

 SYMBOL: status

--- a/extra/mason/email/email.factor
+++ b/extra/mason/email/email.factor
@ -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.
-USING: kernel namespaces accessors combinators make smtp
-debugger prettyprint io io.streams.string io.encodings.utf8
-io.files io.sockets
+USING: kernel namespaces accessors combinators make smtp debugger
+prettyprint io io.streams.string io.encodings.utf8 io.files io.sockets
 mason.common mason.platform mason.config ;
 IN: mason.email

 : prefix-subject ( str -- str' )
    [ "mason on " % platform % ": " % % ] "" make ;

-: email-status ( body subject -- )
+: email-status ( body content-type subject -- )
    <email>
        builder-from get >>from
        builder-recipients get >>to
+        swap >>content-type
        swap prefix-subject >>subject
        swap >>body
    send-email ;
@ -25,11 +25,11 @@ IN: mason.email
    } case ;

 : email-report ( -- )
-    "report" utf8 file-contents subject email-status ;
+    "report" utf8 file-contents "text/html" subject email-status ;

 : email-error ( error callstack -- )
    [
        "Fatal error on " write host-name print nl
        [ error. ] [ callstack. ] bi*
-    ] with-string-writer "fatal error"
+    ] with-string-writer "text/plain" "fatal error"
    email-status ;
--- a/extra/mason/report/report-tests.factor
+++ b/extra/mason/report/report-tests.factor
@ -1,2 +1,4 @@
 IN: mason.report.tests
 USING: mason.report tools.test ;
+
+{ 0 0 } [ [ ] with-report ] must-infer-as
--- a/extra/mason/report/report.factor
+++ b/extra/mason/report/report.factor
@ -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.
-USING: kernel namespaces debugger fry io io.files io.sockets
-io.encodings.utf8 prettyprint benchmark mason.common
-mason.platform mason.config sequences ;
+USING: benchmark combinators.smart debugger fry io assocs
+io.encodings.utf8 io.files io.sockets io.streams.string kernel
+locals mason.common mason.config mason.platform math namespaces
+prettyprint sequences xml.syntax xml.writer ;
 IN: mason.report

-: time. ( file -- )
-    [ write ": " write ] [ eval-file milli-seconds>time print ] bi ;
-
-: common-report ( -- )
-    "Build machine: " write host-name print
-    "CPU: " write target-cpu get print
-    "OS: " write target-os get print
-    "Build directory: " write build-dir print
-    "git id: " write "git-id" eval-file print nl ;
+: common-report ( -- xml )
+    target-os get
+    target-cpu get
+    host-name
+    build-dir
+    "git-id" eval-file
+    [XML
+    <h1>Build report for <->/<-></h1>
+    <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 -- )
-    [ "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 -- )
-    [
-        "VM compile failed:" print nl
-        "compile-log" cat nl
-        error.
-    ] with-report ;
+    "compile-log" "VM compilation failed" failed-report ;

 : boot-failed-report ( error -- )
-    [
-        "Bootstrap failed:" print nl
-        "boot-log" 100 cat-n nl
-        error.
-    ] with-report ;
+    "boot-log" "Bootstrap failed" failed-report ;

 : 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
-        "test-log" 100 cat-n nl
-        error.
-    ] with-report ;
+        1000000 /f
+        [XML <tr><td><-></td><td><-></td></tr> XML]
+    ] { } assoc>map [XML <h2>Benchmarks</h2> <table><-></table> XML] ;

 : successful-report ( -- )
    [
-        boot-time-file time.
-        load-time-file time.
-        test-time-file time.
-        help-lint-time-file time.
-        benchmark-time-file time.
-        html-help-time-file time.
+        [
+            timings-table

-        nl
+            "Load failures"
+            load-everything-vocabs-file
+            load-everything-errors-file
+            fail-dump

-        load-everything-vocabs-file eval-file [
-            "== Did not pass load-everything:" print .
-            load-everything-errors-file cat
-        ] unless-empty
+            "Compiler warnings and errors"
+            compiler-errors-file
+            compiler-error-messages-file
+            fail-dump

-        compiler-errors-file eval-file [
-            "== Vocabularies with compiler errors:" print .
-        ] unless-empty
+            "Unit test failures"
+            test-all-vocabs-file
+            test-all-errors-file
+            fail-dump
+            
+            "Help lint failures"
+            help-lint-vocabs-file
+            help-lint-errors-file
+            fail-dump

-        test-all-vocabs-file eval-file [
-            "== Did not pass test-all:" print .
-            test-all-errors-file cat
-        ] unless-empty
-
-        help-lint-vocabs-file eval-file [
-            "== Did not pass help-lint:" print .
-            help-lint-errors-file cat
-        ] unless-empty
-
-        "== Benchmarks:" print
-        benchmarks-file eval-file benchmarks.
+            "Benchmark errors"
+            benchmark-error-vocabs-file
+            benchmark-error-messages-file
+            fail-dump
+            
+            "Benchmark timings"
+            benchmarks-file eval-file benchmarks-table
+        ] output>array
    ] with-report ;
--- a/extra/mason/test/test.factor
+++ b/extra/mason/test/test.factor
@ -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.
 USING: accessors assocs benchmark bootstrap.stage2
 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-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 1000 /i ; inline