Merge branch 'master' of git://factorcode.org/git/factor

db4
Joe Groff 2009-05-21 20:55:57 -05:00
commit 440861c687
7 changed files with 128 additions and 99 deletions

View File

@ -1,12 +1,11 @@
! Copyright (C) 2008, 2009 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: arrays kernel calendar io.directories io.encodings.utf8 USING: arrays kernel calendar io.directories io.encodings.utf8
io.files io.launcher namespaces prettyprint mason.child mason.cleanup io.files io.launcher namespaces prettyprint combinators mason.child
mason.common mason.help mason.release mason.report mason.email mason.cleanup mason.common mason.help mason.release mason.report
mason.notify ; mason.email mason.notify ;
IN: mason.build
QUALIFIED: continuations QUALIFIED: continuations
IN: mason.build
: create-build-dir ( -- ) : create-build-dir ( -- )
now datestamp stamp set now datestamp stamp set
@ -18,11 +17,12 @@ QUALIFIED: continuations
"git" "clone" builds/factor 3array short-running-process ; "git" "clone" builds/factor 3array short-running-process ;
: begin-build ( -- ) : begin-build ( -- )
"factor" [ git-id ] with-directory "factor" [ git-id ] with-directory {
[ "git-id" to-file ] [ "git-id" to-file ]
[ current-git-id set ] [ "factor/git-id" to-file ]
[ notify-begin-build ] [ current-git-id set ]
tri ; [ notify-begin-build ]
} cleave ;
: build ( -- ) : build ( -- )
create-build-dir create-build-dir

View File

@ -64,7 +64,10 @@ IN: mason.child
MACRO: recover-cond ( alist -- ) MACRO: recover-cond ( alist -- )
dup { [ length 1 = ] [ first callable? ] } 1&& dup { [ length 1 = ] [ first callable? ] } 1&&
[ first ] [ [ first first2 ] [ rest ] bi '[ _ _ [ _ recover-cond ] recover-else ] ] if ; [ first ] [
[ first first2 ] [ rest ] bi
'[ _ _ [ _ recover-cond ] recover-else ]
] if ;
: build-child ( -- status ) : build-child ( -- status )
copy-image copy-image

View File

@ -5,9 +5,12 @@ math.functions make io io.files io.pathnames io.directories
io.directories.hierarchy io.launcher io.encodings.utf8 prettyprint io.directories.hierarchy io.launcher io.encodings.utf8 prettyprint
combinators.short-circuit parser combinators calendar combinators.short-circuit parser combinators calendar
calendar.format arrays mason.config locals debugger fry calendar.format arrays mason.config locals debugger fry
continuations strings ; continuations strings io.sockets ;
IN: mason.common IN: mason.common
: short-host-name ( -- string )
host-name "." split1 drop ;
SYMBOL: current-git-id SYMBOL: current-git-id
: short-running-process ( command -- ) : short-running-process ( command -- )

View File

@ -10,7 +10,7 @@ IN: mason.notify
[ [
"ssh" , status-host get , "-l" , status-username get , "ssh" , status-host get , "-l" , status-username get ,
"./mason-notify" , "./mason-notify" ,
host-name , short-host-name ,
target-cpu get , target-cpu get ,
target-os get , target-os get ,
] { } make prepend ] { } make prepend

View File

@ -4,13 +4,13 @@ USING: benchmark combinators.smart debugger fry io assocs
io.encodings.utf8 io.files io.sockets io.streams.string kernel io.encodings.utf8 io.files io.sockets io.streams.string kernel
locals mason.common mason.config mason.platform math namespaces locals mason.common mason.config mason.platform math namespaces
prettyprint sequences xml.syntax xml.writer combinators.short-circuit prettyprint sequences xml.syntax xml.writer combinators.short-circuit
literals ; literals splitting ;
IN: mason.report IN: mason.report
: common-report ( -- xml ) : common-report ( -- xml )
target-os get target-os get
target-cpu get target-cpu get
host-name short-host-name
build-dir build-dir
current-git-id get current-git-id get
[XML [XML

View File

@ -17,6 +17,19 @@
<p>This package was built from GIT ID <t:xml t:name="git-id" />.</p> <p>This package was built from GIT ID <t:xml t:name="git-id" />.</p>
<p>Once you download Factor, you can <a href="http://concatenative.org/wiki/view/Factor/Getting started">get started</a> with the language.</p> <p>Once you download Factor, you can <a href="http://concatenative.org/wiki/view/Factor/Getting started">get started</a> with the language.</p>
<h1>Build machine information</h1>
<table border="1">
<tr><td>Host name:</td><td><t:xml t:name="host-name" /></td></tr>
<tr><td>Current status:</td><td><t:xml t:name="status" /></td></tr>
<tr><td>Last build:</td><td><t:xml t:name="last-build" /></td></tr>
<tr><td>Last clean build:</td><td><t:xml t:name="last-clean-build" /></td></tr>
<tr><td>Binaries:</td><td><t:xml t:name="binaries" /></td></tr>
<tr><td>Clean images:</td><td><t:xml t:name="clean-images" /></td></tr>
</table>
<p><t:xml t:name="last-report" /></p>
</body> </body>
</html> </html>

View File

@ -4,11 +4,66 @@ USING: accessors arrays combinators db db.tuples furnace.actions
http.server.responses http.server.dispatchers kernel mason.platform http.server.responses http.server.dispatchers kernel mason.platform
mason.notify.server mason.report math.order sequences sorting mason.notify.server mason.report math.order sequences sorting
splitting xml.syntax xml.writer io.pathnames io.encodings.utf8 splitting xml.syntax xml.writer io.pathnames io.encodings.utf8
io.files present validators html.forms furnace.db assocs urls ; io.files present validators html.forms furnace.db urls ;
FROM: assocs => at keys values ;
IN: webapps.mason IN: webapps.mason
TUPLE: mason-app < dispatcher ; TUPLE: mason-app < dispatcher ;
: link ( url label -- xml )
[XML <a href=<->><-></a> XML] ;
: download-link ( builder label -- xml )
[
[ URL" download" ] dip
[ os>> "os" set-query-param ]
[ cpu>> "cpu" set-query-param ] bi
] dip link ;
: download-grid-cell ( cpu os -- xml )
builder new swap >>os swap >>cpu select-tuple dup
[
dup last-release>> dup
[ "." split1 drop 16 tail* 6 head* download-link ] [ 2drop f ] if
] when
[XML <td><-></td> XML] ;
CONSTANT: oses
{
{ "winnt" "Windows" }
{ "macosx" "Mac OS X" }
{ "linux" "Linux" }
{ "freebsd" "FreeBSD" }
{ "netbsd" "NetBSD" }
{ "openbsd" "OpenBSD" }
}
CONSTANT: cpus
{
{ "x86.32" "x86" }
{ "x86.64" "x86-64" }
{ "ppc" "PowerPC" }
}
: download-grid ( -- xml )
oses
[ values [ [XML <th><-></th> XML] ] map ]
[
keys
cpus [
[ nip second ] [ first ] 2bi [
swap download-grid-cell
] curry map [XML <tr><th><-></th><-></tr> XML]
] with map
] bi [XML <table><tr><th/><-></tr><-></table> XML] ;
: <download-grid-action> ( -- action )
<action>
[
download-grid
xml>string "text/html" <content>
] >>display ;
: validate-os/cpu ( -- ) : validate-os/cpu ( -- )
{ {
{ "os" [ v-one-line ] } { "os" [ v-one-line ] }
@ -23,11 +78,6 @@ TUPLE: mason-app < dispatcher ;
[ validate-os/cpu ] >>init [ validate-os/cpu ] >>init
[ current-builder last-report>> "text/html" <content> ] >>display ; [ current-builder last-report>> "text/html" <content> ] >>display ;
: log-file ( -- path ) home "mason.log" append-path ;
: recent-events ( -- xml )
log-file utf8 10 file-tail [XML <pre><-></pre> XML] ;
: git-link ( id -- link ) : git-link ( id -- link )
[ "http://github.com/slavapestov/factor/commit/" prepend ] keep [ "http://github.com/slavapestov/factor/commit/" prepend ] keep
[XML <a href=<->><-></a> XML] ; [XML <a href=<->><-></a> XML] ;
@ -36,19 +86,22 @@ TUPLE: mason-app < dispatcher ;
swap current-git-id>> git-link swap current-git-id>> git-link
[XML <-> for <-> XML] ; [XML <-> for <-> XML] ;
: status-string ( builder -- string )
dup status>> {
{ +dirty+ [ drop "Dirty" ] }
{ +clean+ [ drop "Clean" ] }
{ +error+ [ drop "Error" ] }
{ +starting+ [ "Starting build" building ] }
{ +make-vm+ [ "Compiling VM" building ] }
{ +boot+ [ "Bootstrapping" building ] }
{ +test+ [ "Testing" building ] }
[ 2drop "Unknown" ]
} case ;
: current-status ( builder -- xml ) : current-status ( builder -- xml )
[ [ status-string ]
dup status>> { [ current-timestamp>> present " (as of " ")" surround ] bi
{ +dirty+ [ drop "Dirty" ] } 2array ;
{ +clean+ [ drop "Clean" ] }
{ +error+ [ drop "Error" ] }
{ +starting+ [ "Starting build" building ] }
{ +make-vm+ [ "Compiling VM" building ] }
{ +boot+ [ "Bootstrapping" building ] }
{ +test+ [ "Testing" building ] }
[ 2drop "Unknown" ]
} case
] [ current-timestamp>> present " (as of " ")" surround ] bi 2array ;
: build-status ( git-id timestamp -- xml ) : build-status ( git-id timestamp -- xml )
over [ [ git-link ] [ present ] bi* " (built on " ")" surround 2array ] [ 2drop f ] if ; over [ [ git-link ] [ present ] bi* " (built on " ")" surround 2array ] [ 2drop f ] if ;
@ -56,23 +109,17 @@ TUPLE: mason-app < dispatcher ;
: binaries-url ( builder -- url ) : binaries-url ( builder -- url )
[ os>> ] [ cpu>> ] bi (platform) "http://downloads.factorcode.org/" prepend ; [ os>> ] [ cpu>> ] bi (platform) "http://downloads.factorcode.org/" prepend ;
: url-link ( url -- xml )
dup [XML <a href=<->><-></a> XML] ;
: latest-binary-link ( builder -- xml ) : latest-binary-link ( builder -- xml )
[ URL" download" ] dip [ binaries-url ] [ last-release>> ] bi [ "/" glue ] keep link ;
[ os>> "os" set-query-param ]
[ cpu>> "cpu" set-query-param ] bi
[XML <a href=<->>Latest download</a> XML] ;
: binaries-link ( builder -- link ) : binaries-link ( builder -- link )
binaries-url url-link ; binaries-url dup link ;
: clean-image-url ( builder -- url ) : clean-image-url ( builder -- url )
[ os>> ] [ cpu>> ] bi (platform) "http://factorcode.org/images/clean/" prepend ; [ os>> ] [ cpu>> ] bi (platform) "http://factorcode.org/images/clean/" prepend ;
: clean-image-link ( builder -- link ) : clean-image-link ( builder -- link )
clean-image-url url-link ; clean-image-url dup link ;
: report-link ( builder -- xml ) : report-link ( builder -- xml )
[ URL" report" ] dip [ URL" report" ] dip
@ -80,56 +127,6 @@ TUPLE: mason-app < dispatcher ;
[ cpu>> "cpu" set-query-param ] bi [ cpu>> "cpu" set-query-param ] bi
[XML <a href=<->>Latest build report</a> XML] ; [XML <a href=<->>Latest build report</a> XML] ;
: machine-table ( builder -- xml )
{
[ os>> ]
[ cpu>> ]
[ host-name>> "." split1 drop ]
[ current-status ]
[ [ last-git-id>> ] [ last-timestamp>> ] bi build-status ]
[ [ clean-git-id>> ] [ clean-timestamp>> ] bi build-status ]
[ binaries-link ]
[ clean-image-link ]
[ report-link ]
[ latest-binary-link ]
} cleave
[XML
<h2><-> / <-></h2>
<table border="1">
<tr><td>Host name:</td><td><-></td></tr>
<tr><td>Current status:</td><td><-></td></tr>
<tr><td>Last build:</td><td><-></td></tr>
<tr><td>Last clean build:</td><td><-></td></tr>
<tr><td>Binaries:</td><td><-></td></tr>
<tr><td>Clean images:</td><td><-></td></tr>
</table>
<-> | <->
XML] ;
: machine-report ( -- xml )
builder new select-tuples
[ [ [ os>> ] [ cpu>> ] bi 2array ] compare ] sort
[ machine-table ] map ;
: build-farm-summary ( -- xml )
recent-events
machine-report
[XML
<html>
<head><title>Factor build farm</title></head>
<body><h1>Recent events</h1><-> <h1>Machine status</h1><-></body>
</html>
XML] ;
: <summary-action> ( -- action )
<action>
[ build-farm-summary xml>string "text/html" <content> ] >>display ;
TUPLE: builder-link href title ;
C: <builder-link> builder-link
: requirements ( builder -- xml ) : requirements ( builder -- xml )
[ [
os>> { os>> {
@ -141,7 +138,7 @@ C: <builder-link> builder-link
{ "openbsd" "OpenBSD 4.2" } { "openbsd" "OpenBSD 4.2" }
} at } at
] [ ] [
dup cpu>> "x86-32" = [ dup cpu>> "x86.32" = [
os>> { os>> {
{ [ dup { "winnt" "linux" } member? ] [ drop "Intel Pentium 4, Core Duo, or other x86 chip with SSE2 support. Note that 32-bit Athlon XP processors do not support SSE2." ] } { [ dup { "winnt" "linux" } member? ] [ drop "Intel Pentium 4, Core Duo, or other x86 chip with SSE2 support. Note that 32-bit Athlon XP processors do not support SSE2." ] }
{ [ dup { "freebsd" "netbsd" "openbsd" } member? ] [ drop "Intel Pentium Pro or better" ] } { [ dup { "freebsd" "netbsd" "openbsd" } member? ] [ drop "Intel Pentium Pro or better" ] }
@ -151,23 +148,36 @@ C: <builder-link> builder-link
] bi ] bi
2array sift [ [XML <li><-></li> XML] ] map [XML <ul><-></ul> XML] ; 2array sift [ [XML <li><-></li> XML] ] map [XML <ul><-></ul> XML] ;
: last-build-status ( builder -- xml )
[ last-git-id>> ] [ last-timestamp>> ] bi build-status ;
: clean-build-status ( builder -- xml )
[ clean-git-id>> ] [ clean-timestamp>> ] bi build-status ;
: <download-binary-action> ( -- action ) : <download-binary-action> ( -- action )
<page-action> <page-action>
[ [
validate-os/cpu validate-os/cpu
"os" value "cpu" value (platform) "platform" set-value "os" value "cpu" value (platform) "platform" set-value
current-builder current-builder {
[ latest-binary-link "package" set-value ] [ latest-binary-link "package" set-value ]
[ release-git-id>> git-link "git-id" set-value ] [ release-git-id>> git-link "git-id" set-value ]
[ requirements "requirements" set-value ] [ requirements "requirements" set-value ]
tri [ host-name>> "host-name" set-value ]
[ current-status "status" set-value ]
[ last-build-status "last-build" set-value ]
[ clean-build-status "last-clean-build" set-value ]
[ binaries-link "binaries" set-value ]
[ clean-image-link "clean-images" set-value ]
[ report-link "last-report" set-value ]
} cleave
] >>init ] >>init
{ mason-app "download" } >>template ; { mason-app "download" } >>template ;
: <mason-app> ( -- dispatcher ) : <mason-app> ( -- dispatcher )
mason-app new-dispatcher mason-app new-dispatcher
<summary-action> "" add-responder
<build-report-action> "report" add-responder <build-report-action> "report" add-responder
<download-binary-action> "download" add-responder <download-binary-action> "download" add-responder
<download-grid-action> "grid" add-responder
mason-db <db-persistence> ; mason-db <db-persistence> ;