Merge branch 'master' of git://factorcode.org/git/factor
Joe Groff
commit
440861c687
|
|
@ -1,12 +1,11 @@
|
|||
! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel calendar io.directories io.encodings.utf8
|
||||
io.files io.launcher namespaces prettyprint mason.child mason.cleanup
|
||||
mason.common mason.help mason.release mason.report mason.email
|
||||
mason.notify ;
|
||||
IN: mason.build
|
||||
|
||||
io.files io.launcher namespaces prettyprint combinators mason.child
|
||||
mason.cleanup mason.common mason.help mason.release mason.report
|
||||
mason.email mason.notify ;
|
||||
QUALIFIED: continuations
|
||||
IN: mason.build
|
||||
|
||||
: create-build-dir ( -- )
|
||||
now datestamp stamp set
|
||||
|
|
@ -18,11 +17,12 @@ QUALIFIED: continuations
|
|||
"git" "clone" builds/factor 3array short-running-process ;
|
||||
|
||||
: begin-build ( -- )
|
||||
"factor" [ git-id ] with-directory
|
||||
[ "git-id" to-file ]
|
||||
[ current-git-id set ]
|
||||
[ notify-begin-build ]
|
||||
tri ;
|
||||
"factor" [ git-id ] with-directory {
|
||||
[ "git-id" to-file ]
|
||||
[ "factor/git-id" to-file ]
|
||||
[ current-git-id set ]
|
||||
[ notify-begin-build ]
|
||||
} cleave ;
|
||||
|
||||
: build ( -- )
|
||||
create-build-dir
|
||||
|
|
|
|||
|
|
@ -64,7 +64,10 @@ IN: mason.child
|
|||
|
||||
MACRO: recover-cond ( alist -- )
|
||||
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 )
|
||||
copy-image
|
||||
|
|
|
|||
|
|
@ -5,9 +5,12 @@ 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 debugger fry
|
||||
continuations strings ;
|
||||
continuations strings io.sockets ;
|
||||
IN: mason.common
|
||||
|
||||
: short-host-name ( -- string )
|
||||
host-name "." split1 drop ;
|
||||
|
||||
SYMBOL: current-git-id
|
||||
|
||||
: short-running-process ( command -- )
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ IN: mason.notify
|
|||
[
|
||||
"ssh" , status-host get , "-l" , status-username get ,
|
||||
"./mason-notify" ,
|
||||
host-name ,
|
||||
short-host-name ,
|
||||
target-cpu get ,
|
||||
target-os get ,
|
||||
] { } make prepend
|
||||
|
|
|
|||
|
|
@ -4,13 +4,13 @@ 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 combinators.short-circuit
|
||||
literals ;
|
||||
literals splitting ;
|
||||
IN: mason.report
|
||||
|
||||
: common-report ( -- xml )
|
||||
target-os get
|
||||
target-cpu get
|
||||
host-name
|
||||
short-host-name
|
||||
build-dir
|
||||
current-git-id get
|
||||
[XML
|
||||
|
|
|
|||
|
|
@ -17,6 +17,19 @@
|
|||
<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>
|
||||
|
||||
<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>
|
||||
</html>
|
||||
|
||||
|
|
|
|||
|
|
@ -4,11 +4,66 @@ USING: accessors arrays combinators db db.tuples furnace.actions
|
|||
http.server.responses http.server.dispatchers kernel mason.platform
|
||||
mason.notify.server mason.report math.order sequences sorting
|
||||
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
|
||||
|
||||
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 ( -- )
|
||||
{
|
||||
{ "os" [ v-one-line ] }
|
||||
|
|
@ -23,11 +78,6 @@ TUPLE: mason-app < dispatcher ;
|
|||
[ validate-os/cpu ] >>init
|
||||
[ 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 )
|
||||
[ "http://github.com/slavapestov/factor/commit/" prepend ] keep
|
||||
[XML <a href=<->><-></a> XML] ;
|
||||
|
|
@ -36,19 +86,22 @@ TUPLE: mason-app < dispatcher ;
|
|||
swap current-git-id>> git-link
|
||||
[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 )
|
||||
[
|
||||
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-timestamp>> present " (as of " ")" surround ] bi 2array ;
|
||||
[ status-string ]
|
||||
[ current-timestamp>> present " (as of " ")" surround ] bi
|
||||
2array ;
|
||||
|
||||
: build-status ( git-id timestamp -- xml )
|
||||
over [ [ git-link ] [ present ] bi* " (built on " ")" surround 2array ] [ 2drop f ] if ;
|
||||
|
|
@ -56,23 +109,17 @@ TUPLE: mason-app < dispatcher ;
|
|||
: binaries-url ( builder -- url )
|
||||
[ os>> ] [ cpu>> ] bi (platform) "http://downloads.factorcode.org/" prepend ;
|
||||
|
||||
: url-link ( url -- xml )
|
||||
dup [XML <a href=<->><-></a> XML] ;
|
||||
|
||||
: latest-binary-link ( builder -- xml )
|
||||
[ URL" download" ] dip
|
||||
[ os>> "os" set-query-param ]
|
||||
[ cpu>> "cpu" set-query-param ] bi
|
||||
[XML <a href=<->>Latest download</a> XML] ;
|
||||
[ binaries-url ] [ last-release>> ] bi [ "/" glue ] keep link ;
|
||||
|
||||
: binaries-link ( builder -- link )
|
||||
binaries-url url-link ;
|
||||
binaries-url dup link ;
|
||||
|
||||
: clean-image-url ( builder -- url )
|
||||
[ os>> ] [ cpu>> ] bi (platform) "http://factorcode.org/images/clean/" prepend ;
|
||||
|
||||
: clean-image-link ( builder -- link )
|
||||
clean-image-url url-link ;
|
||||
clean-image-url dup link ;
|
||||
|
||||
: report-link ( builder -- xml )
|
||||
[ URL" report" ] dip
|
||||
|
|
@ -80,56 +127,6 @@ TUPLE: mason-app < dispatcher ;
|
|||
[ cpu>> "cpu" set-query-param ] bi
|
||||
[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 )
|
||||
[
|
||||
os>> {
|
||||
|
|
@ -141,7 +138,7 @@ C: <builder-link> builder-link
|
|||
{ "openbsd" "OpenBSD 4.2" }
|
||||
} at
|
||||
] [
|
||||
dup cpu>> "x86-32" = [
|
||||
dup cpu>> "x86.32" = [
|
||||
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 { "freebsd" "netbsd" "openbsd" } member? ] [ drop "Intel Pentium Pro or better" ] }
|
||||
|
|
@ -151,23 +148,36 @@ C: <builder-link> builder-link
|
|||
] bi
|
||||
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 )
|
||||
<page-action>
|
||||
[
|
||||
validate-os/cpu
|
||||
"os" value "cpu" value (platform) "platform" set-value
|
||||
current-builder
|
||||
[ latest-binary-link "package" set-value ]
|
||||
[ release-git-id>> git-link "git-id" set-value ]
|
||||
[ requirements "requirements" set-value ]
|
||||
tri
|
||||
current-builder {
|
||||
[ latest-binary-link "package" set-value ]
|
||||
[ release-git-id>> git-link "git-id" set-value ]
|
||||
[ requirements "requirements" set-value ]
|
||||
[ 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
|
||||
{ mason-app "download" } >>template ;
|
||||
|
||||
: <mason-app> ( -- dispatcher )
|
||||
mason-app new-dispatcher
|
||||
<summary-action> "" add-responder
|
||||
<build-report-action> "report" add-responder
|
||||
<download-binary-action> "download" add-responder
|
||||
<download-grid-action> "grid" add-responder
|
||||
mason-db <db-persistence> ;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue