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

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

db4
Slava Pestov 2009-04-17 20:59:59 -05:00
parent 3586736b34
commit af600d5aac
17 changed files with 208 additions and 100 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
extra/mason/build/build.factor
View File

@ -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 ( -- )
"factor" [ git-id ] with-directory "git-id" to-file ;
: begin-build ( -- )
"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
release
[ notify-report ]
[ status-clean eq? [ upload-help release ] when ] bi
] [ cleanup ] [ ] continuations:cleanup ;
MAIN: build

20
extra/mason/child/child-tests.factor
View File

@ -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

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

@ -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? ]
[ 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 ( -- )
[
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 ;
{ [ notify-make-vm make-vm ] [ compile-failed ] }
{ [ notify-boot boot ] [ boot-failed ] }
{ [ notify-test test ] [ test-failed ] }
[ success ]
} recover-cond ;

9
extra/mason/cleanup/cleanup.factor
View File

@ -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? [
{ "bzip2" "test-log" } try-process
] when ;
"test-log" compress ;
: cleanup ( -- )
builder-debug get [

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

@ -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

15
extra/mason/config/config.factor
View File

@ -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.

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

@ -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 )
status get {
: subject ( status -- str )
{
{ status-clean [ "clean" ] }
{ status-dirty [ "dirty" ] }
{ status-error [ "error" ] }
} case ;
: email-report ( -- )
"report" utf8 file-contents "text/html" subject email-status ;
: email-report ( report status -- )
[ "text/html" ] dip subject email-status ;
: email-error ( error callstack -- )
[

11
extra/mason/help/help.factor
View File

@ -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 ;
] when ;

3
extra/mason/mason.factor
View File

@ -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

1
extra/mason/notify/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

48
extra/mason/notify/notify.factor Normal file
View File

@ -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 ;

22
extra/mason/release/archive/archive.factor
View File

@ -18,23 +18,23 @@ IN: mason.release.archive
: archive-name ( -- string ) base-name extension append ;
: make-windows-archive ( -- )
[ "zip" , "-r" , archive-name , "factor" , ] { } make try-process ;
: make-windows-archive ( archive-name -- )
[ "zip" , "-r" , , "factor" , ] { } make try-output-process ;
: make-macosx-archive ( -- )
{ "mkdir" "dmg-root" } try-process
{ "cp" "-R" "factor" "dmg-root" } try-process
: make-macosx-archive ( archive-name -- )
{ "mkdir" "dmg-root" } try-output-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 ( -- )
[ "tar" , "-cvzf" , archive-name , "factor" , ] { } make try-process ;
: make-unix-archive ( archive-name -- )
[ "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 ( -- )
archive-name releases move-file-into ;
: save-archive ( archive-name -- )
releases move-file-into ;

19
extra/mason/release/release.factor
View File

@ -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
upload
save-archive ;
: release ( -- ) status get status-clean eq? [ (release) ] when ;
archive-name {
[ make-archive ]
[ upload ]
[ save-archive ]
[ notify-release ]
} cleave ;

11
extra/mason/release/upload/upload.factor
View File

@ -8,14 +8,13 @@ IN: mason.release.upload
: remote-location ( -- dest )
upload-directory get "/" platform 3append ;
: remote-archive-name ( -- dest )
remote-location "/" archive-name 3append ;
: remote-archive-name ( archive-name -- dest )
[ 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 ;

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

@ -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 ;
] 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 ? ;

1
extra/mason/twitter/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

14
extra/mason/twitter/twitter.factor Normal file
View File

@ -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 ;