mason: working on a big overhaul of mason. Status updates sent to a web service, binary upload notification via Twitter

extra/mason/build/build.factor

@@ -1,8 +1,9 @@
-! 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: arrays calendar io.directories io.encodings.utf8
+USING: arrays kernel calendar io.directories io.encodings.utf8
 io.files io.launcher mason.child mason.cleanup mason.common
-mason.help mason.release mason.report namespaces prettyprint ;
+mason.help mason.release mason.report mason.email mason.notify
+namespaces prettyprint ;
 IN: mason.build
 
 QUALIFIED: continuations
@@ -14,20 +15,21 @@ QUALIFIED: continuations
 : enter-build-dir  ( -- ) build-dir set-current-directory ;
 
 : clone-builds-factor ( -- )
-    "git" "clone" builds/factor 3array try-process ;
+    "git" "clone" builds/factor 3array try-output-process ;
 
-: record-id ( -- )
+: begin-build ( -- )
-    "factor" [ git-id ] with-directory "git-id" to-file ;
+    "factor" [ git-id ] with-directory
+    [ "git-id" to-file ] [ notify-begin-build ] bi ;
 
 : build ( -- )
     create-build-dir
     enter-build-dir
     clone-builds-factor
     [
-        record-id
+        begin-build
         build-child
-        upload-help
+        [ notify-report ]
-        release
+        [ status-clean eq? [ upload-help release ] when ] bi
     ] [ cleanup ] [ ] continuations:cleanup ;
 
 MAIN: build

extra/mason/child/child-tests.factor

@@ -40,3 +40,23 @@ USING: mason.child mason.config tools.test namespaces ;
         boot-cmd
     ] with-scope
 ] unit-test
+
+[ [ "Hi" print ] [ drop 3 ] [ 4 ] recover-else ] must-infer
+
+[ 4 ] [ [ "Hi" print ] [ drop 3 ] [ 4 ] recover-else ] unit-test
+
+[ 3 ] [ [ "Hi" throw ] [ drop 3 ] [ 4 ] recover-else ] unit-test
+
+[ "A" ] [
+    {
+        { [ 3 throw ] [ { "X" "Y" "Z" "A" } nth ] }
+        [ "B" ]
+    } recover-cond
+] unit-test
+
+[ "B" ] [
+    {
+        { [ ] [ ] }
+        [ "B" ]
+    } recover-cond
+] unit-test

extra/mason/child/child.factor

@@ -1,9 +1,10 @@
 ! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays calendar combinators.short-circuit
+USING: accessors arrays calendar combinators.short-circuit fry
 continuations debugger io.directories io.files io.launcher
 io.pathnames io.encodings.ascii kernel make mason.common mason.config
-mason.platform mason.report mason.email namespaces sequences ;
+mason.platform mason.report mason.notify namespaces sequences
+quotations macros ;
 IN: mason.child
 
 : make-cmd ( -- args )
@@ -58,30 +59,18 @@ IN: mason.child
         try-process
     ] with-directory ;
 
-: return-with ( obj -- * ) return-continuation get continue-with ;
+: recover-else ( try catch else -- )
+    [ [ '[ @ f t ] ] [ '[ @ f ] ] bi* recover ] dip '[ drop @ ] when ; inline
 
-: build-clean? ( -- ? )
+MACRO: recover-cond ( alist -- )
+    dup { [ length 1 = ] [ first callable? ] } 1&&
+    [ first ] [ [ first first2 ] [ rest ] bi '[ _ _ [ _ recover-cond ] recover-else ] ] if ;
+
+: build-child ( -- status )
+    copy-image
     {
-        [ load-everything-vocabs-file eval-file empty? ]
+        { [ notify-make-vm make-vm ] [ compile-failed ] }
-        [ test-all-vocabs-file eval-file empty? ]
+        { [ notify-boot boot ] [ boot-failed ] }
-        [ help-lint-vocabs-file eval-file empty? ]
+        { [ notify-test test ] [ test-failed ] }
-        [ compiler-errors-file eval-file empty? ]
+        [ success ]
-        [ benchmark-error-vocabs-file eval-file empty? ]
+    } recover-cond ;
-    } 0&& ;
-
-: build-child ( -- )
-    [
-        return-continuation set
-
-        copy-image
-
-        [ make-vm ] [ compile-failed-report status-error return-with ] recover
-        [ boot ] [ boot-failed-report status-error return-with ] recover
-        [ test ] [ test-failed-report status-error return-with ] recover
-
-        successful-report
-
-        build-clean? status-clean status-dirty ? return-with
-    ] callcc1
-    status set
-    email-report ;

extra/mason/cleanup/cleanup.factor

@@ -5,13 +5,14 @@ io.directories.hierarchy io.files io.launcher kernel
 mason.common mason.config mason.platform namespaces ;
 IN: mason.cleanup
 
+: compress ( filename -- )
+    dup exists? [ "bzip2" swap 2array try-output-process ] [ drop ] if ;
+
 : compress-image ( -- )
-    "bzip2" boot-image-name 2array try-process ;
+    boot-image-name compress ;
 
 : compress-test-log ( -- )
-    "test-log" exists? [
+    "test-log" compress ;
-        { "bzip2" "test-log" } try-process
-    ] when ;
 
 : cleanup ( -- )
     builder-debug get [

extra/mason/common/common.factor

@@ -4,15 +4,27 @@ USING: kernel namespaces sequences splitting system accessors
 math.functions make io io.files io.pathnames io.directories
 io.directories.hierarchy io.launcher io.encodings.utf8 prettyprint
 combinators.short-circuit parser combinators calendar
-calendar.format arrays mason.config locals system ;
+calendar.format arrays mason.config locals system debugger ;
 IN: mason.common
 
+ERROR: output-process-error output process ;
+
+M: output-process-error error.
+    [ "Process:" print process>> . nl ]
+    [ "Output:" print output>> print ]
+    bi ;
+
+: try-output-process ( command -- )
+    >process +stdout+ >>stderr utf8 <process-reader*>
+    [ contents ] [ dup wait-for-process ] bi*
+    0 = [ 2drop ] [ output-process-error ] if ;
+
 HOOK: really-delete-tree os ( path -- )
 
 M: windows really-delete-tree
     #! Workaround: Cygwin GIT creates read-only files for
     #! some reason.
-    [ { "chmod" "ug+rw" "-R" } swap (normalize-path) suffix try-process ]
+    [ { "chmod" "ug+rw" "-R" } swap (normalize-path) suffix try-output-process ]
     [ delete-tree ]
     bi ;
 
@@ -23,7 +35,7 @@ M: unix really-delete-tree delete-tree ;
     <process>
         swap >>command
         15 minutes >>timeout
-    try-process ;
+    try-output-process ;
 
 :: upload-safely ( local username host remote -- )
     [let* | temp [ remote ".incomplete" append ]
@@ -68,7 +80,7 @@ SYMBOL: stamp
 : prepare-build-machine ( -- )
     builds-dir get make-directories
     builds-dir get
-    [ { "git" "clone" "git://factorcode.org/git/factor.git" } try-process ]
+    [ { "git" "clone" "git://factorcode.org/git/factor.git" } try-output-process ]
     with-directory ;
 
 : git-id ( -- id )
@@ -101,8 +113,6 @@ CONSTANT: benchmarks-file "benchmarks"
 CONSTANT: benchmark-error-messages-file "benchmark-error-messages"
 CONSTANT: benchmark-error-vocabs-file "benchmark-error-vocabs"
 
-SYMBOL: status
-
 SYMBOL: status-error ! didn't bootstrap, or crashed
 SYMBOL: status-dirty ! bootstrapped but not all tests passed
 SYMBOL: status-clean ! everything good

extra/mason/config/config.factor

@@ -11,12 +11,17 @@ builds-dir get-global [
     home "builds" append-path builds-dir set-global
 ] unless
 
-! Who sends build reports.
+! Who sends build report e-mails.
 SYMBOL: builder-from
 
-! Who receives build reports.
+! Who receives build report e-mails.
 SYMBOL: builder-recipients
 
+! (Optional) twitter credentials for status updates.
+SYMBOL: builder-twitter-username
+
+SYMBOL: builder-twitter-password
+
 ! (Optional) CPU architecture to build for.
 SYMBOL: target-cpu
 
@@ -34,6 +39,12 @@ target-os get-global [
 ! Keep test-log around?
 SYMBOL: builder-debug
 
+! Host to send status notifications to.
+SYMBOL: status-host
+
+! Username to log in.
+SYMBOL: status-username
+
 SYMBOL: upload-help?
 
 ! The below are only needed if upload-help is true.

extra/mason/email/email.factor

@@ -12,20 +12,20 @@ IN: mason.email
     <email>
         builder-from get >>from
         builder-recipients get >>to
-        swap >>content-type
         swap prefix-subject >>subject
+        swap >>content-type
         swap >>body
     send-email ;
 
-: subject ( -- str )
+: subject ( status -- str )
-    status get {
+    {
         { status-clean [ "clean" ] }
         { status-dirty [ "dirty" ] }
         { status-error [ "error" ] }
     } case ;
 
-: email-report ( -- )
+: email-report ( report status -- )
-    "report" utf8 file-contents "text/html" subject email-status ;
+    [ "text/html" ] dip subject email-status ;
 
 : email-error ( error callstack -- )
     [

extra/mason/help/help.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays help.html io.directories io.files io.launcher
 kernel make mason.common mason.config namespaces sequences ;
@@ -6,7 +6,7 @@ IN: mason.help
 
 : make-help-archive ( -- )
     "factor/temp" [
-        { "tar" "cfz" "docs.tar.gz" "docs" } try-process
+        { "tar" "cfz" "docs.tar.gz" "docs" } try-output-process
     ] with-directory ;
 
 : upload-help-archive ( -- )
@@ -16,11 +16,8 @@ IN: mason.help
     help-directory get "/docs.tar.gz" append
     upload-safely ;
 
-: (upload-help) ( -- )
+: upload-help ( -- )
     upload-help? get [
         make-help-archive
         upload-help-archive
     ] when ;
-
-: upload-help ( -- )
-    status get status-clean eq? [ (upload-help) ] when ;

extra/mason/mason.factor

@@ -6,7 +6,8 @@ mason.email mason.updates namespaces threads ;
 IN: mason
 
 : build-loop-error ( error -- )
-    error-continuation get call>> email-error ;
+    [ "Build loop error:" print flush error. flush ]
+    [ error-continuation get call>> email-error ] bi ;
 
 : build-loop-fatal ( error -- )
     "FATAL BUILDER ERROR:" print

extra/mason/notify/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/mason/notify/notify.factor

@@ -0,0 +1,48 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays accessors io io.sockets io.encodings.utf8 io.files
+io.launcher kernel make mason.config mason.common mason.email
+mason.twitter namespaces sequences ;
+IN: mason.notify
+
+: status-notify ( input-file args -- )
+    status-host get [
+        [
+            "ssh" , status-host get , "-l" , status-username get ,
+            "./mason-notify" ,
+            host-name ,
+            target-cpu get ,
+            target-os get ,
+        ] { } make prepend
+        <process>
+            swap >>command
+            swap [ +closed+ ] unless* >>stdin
+        try-output-process
+    ] [ 2drop ] if ;
+
+: notify-begin-build ( git-id -- )
+    [ "Starting build of GIT ID " write print flush ]
+    [ f swap "git-id" swap 2array status-notify ]
+    bi ;
+
+: notify-make-vm ( -- )
+    "Compiling VM" print flush
+    f { "make-vm" } status-notify ;
+
+: notify-boot ( -- )
+    "Bootstrapping" print flush
+    f { "boot" } status-notify ;
+
+: notify-test ( -- )
+    "Running tests" print flush
+    f { "test" } status-notify ;
+
+: notify-report ( status -- )
+    [ "Build finished with status: " write print flush ]
+    [
+        [ "report" utf8 file-contents ] dip email-report
+        "report" { "report" } status-notify
+    ] bi ;
+
+: notify-release ( archive-name -- )
+    "Uploaded " prepend [ print flush ] [ mason-tweet ] bi ;

extra/mason/release/archive/archive.factor

@@ -18,23 +18,23 @@ IN: mason.release.archive
 
 : archive-name ( -- string ) base-name extension append ;
 
-: make-windows-archive ( -- )
+: make-windows-archive ( archive-name -- )
-    [ "zip" , "-r" , archive-name , "factor" , ] { } make try-process ;
+    [ "zip" , "-r" , , "factor" , ] { } make try-output-process ;
 
-: make-macosx-archive ( -- )
+: make-macosx-archive ( archive-name -- )
-    { "mkdir" "dmg-root" } try-process
+    { "mkdir" "dmg-root" } try-output-process
-    { "cp" "-R" "factor" "dmg-root" } try-process
+    { "cp" "-R" "factor" "dmg-root" } try-output-process
     { "hdiutil" "create"
         "-srcfolder" "dmg-root"
         "-fs" "HFS+"
     "-volname" "factor" }
-    archive-name suffix try-process
+    swap suffix try-output-process
     "dmg-root" really-delete-tree ;
 
-: make-unix-archive ( -- )
+: make-unix-archive ( archive-name -- )
-    [ "tar" , "-cvzf" , archive-name , "factor" , ] { } make try-process ;
+    [ "tar" , "-cvzf" , , "factor" , ] { } make try-output-process ;
 
-: make-archive ( -- )
+: make-archive ( archive-name -- )
     target-os get {
         { "winnt" [ make-windows-archive ] }
         { "macosx" [ make-macosx-archive ] }
@@ -44,5 +44,5 @@ IN: mason.release.archive
 : releases ( -- path )
     builds-dir get "releases" append-path dup make-directories ;
 
-: save-archive ( -- )
+: save-archive ( archive-name -- )
-    archive-name releases move-file-into ;
+    releases move-file-into ;

extra/mason/release/release.factor

@@ -1,16 +1,17 @@
-! Copyright (C) 2008 Eduardo Cavazos.
+! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel debugger namespaces sequences splitting
+USING: kernel debugger namespaces sequences splitting combinators
 combinators io io.files io.launcher prettyprint bootstrap.image
 mason.common mason.release.branch mason.release.tidy
-mason.release.archive mason.release.upload ;
+mason.release.archive mason.release.upload mason.notify ;
 IN: mason.release
 
-: (release) ( -- )
+: release ( -- )
     update-clean-branch
     tidy
-    make-archive
+    archive-name {
-    upload
+        [ make-archive ]
-    save-archive ;
+        [ upload ]
-
+        [ save-archive ]
-: release ( -- ) status get status-clean eq? [ (release) ] when ;
+        [ notify-release ]
+    } cleave ;

extra/mason/release/upload/upload.factor

@@ -8,14 +8,13 @@ IN: mason.release.upload
 : remote-location ( -- dest )
     upload-directory get "/" platform 3append ;
 
-: remote-archive-name ( -- dest )
+: remote-archive-name ( archive-name -- dest )
-    remote-location "/" archive-name 3append ;
+    [ remote-location "/" ] dip 3append ;
 
-: upload ( -- )
+: upload ( archive-name -- )
     upload-to-factorcode? get [
-        archive-name
         upload-username get
         upload-host get
-        remote-archive-name
+        pick remote-archive-name
         upload-safely
-    ] when ;
+    ] [ drop ] if ;

extra/mason/report/report.factor

@@ -3,7 +3,7 @@
 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 ;
+prettyprint sequences xml.syntax xml.writer combinators.short-circuit ;
 IN: mason.report
 
 : common-report ( -- xml )
@@ -30,7 +30,7 @@ IN: mason.report
         pprint-xml
     ] with-file-writer ; inline
 
-:: failed-report ( error file what -- )
+:: failed-report ( error file what -- status )
     [
         error [ error. ] with-string-writer :> error
         file utf8 file-contents 400 short tail* :> output
@@ -42,15 +42,16 @@ IN: mason.report
         Launcher error:
         <pre><-error-></pre>
         XML]
-    ] with-report ;
+    ] with-report
+    status-error ;
 
-: compile-failed-report ( error -- )
+: compile-failed ( error -- status )
     "compile-log" "VM compilation failed" failed-report ;
 
-: boot-failed-report ( error -- )
+: boot-failed ( error -- status )
     "boot-log" "Bootstrap failed" failed-report ;
 
-: test-failed-report ( error -- )
+: test-failed ( error -- status )
     "test-log" "Tests failed" failed-report ;
 
 : timings-table ( -- xml )
@@ -66,7 +67,7 @@ IN: mason.report
         [XML <tr><td><-></td><td><-></td></tr> XML]
     ] map [XML <h2>Timings</h2> <table><-></table> XML] ;
 
-: fail-dump ( heading vocabs-file messages-file -- xml )
+: error-dump ( heading vocabs-file messages-file -- xml )
     [ eval-file ] dip over empty? [ 3drop f ] [
         [ ]
         [ [ [XML <li><-></li> XML] ] map [XML <ul><-></ul> XML] ]
@@ -89,29 +90,41 @@ IN: mason.report
             "Load failures"
             load-everything-vocabs-file
             load-everything-errors-file
-            fail-dump
+            error-dump
 
             "Compiler warnings and errors"
             compiler-errors-file
             compiler-error-messages-file
-            fail-dump
+            error-dump
 
             "Unit test failures"
             test-all-vocabs-file
             test-all-errors-file
-            fail-dump
+            error-dump
             
             "Help lint failures"
             help-lint-vocabs-file
             help-lint-errors-file
-            fail-dump
+            error-dump
 
             "Benchmark errors"
             benchmark-error-vocabs-file
             benchmark-error-messages-file
-            fail-dump
+            error-dump
             
             "Benchmark timings"
             benchmarks-file eval-file benchmarks-table
         ] output>array
     ] with-report ;
+
+: build-clean? ( -- ? )
+    {
+        [ load-everything-vocabs-file eval-file empty? ]
+        [ 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&& ;
+
+: success ( -- status )
+    successful-report build-clean? status-clean status-dirty ? ;

extra/mason/twitter/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/mason/twitter/twitter.factor

@@ -0,0 +1,14 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: debugger fry kernel mason.config namespaces twitter ;
+IN: mason.twitter
+
+: mason-tweet ( message -- )
+    builder-twitter-username get builder-twitter-password get and
+    [
+        [
+            builder-twitter-username get twitter-username set
+            builder-twitter-password get twitter-password set
+            '[ _ tweet ] try
+        ] with-scope
+    ] [ drop ] if ;