diff --git a/extra/mason/build/build.factor b/extra/mason/build/build.factor
index a9e32e5315..f2018449fc 100644
--- a/extra/mason/build/build.factor
+++ b/extra/mason/build/build.factor
@@ -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
diff --git a/extra/mason/child/child.factor b/extra/mason/child/child.factor
index 8132e62078..4a9a864c40 100755
--- a/extra/mason/child/child.factor
+++ b/extra/mason/child/child.factor
@@ -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
diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor
index d54a17ff91..22e37f8a8c 100755
--- a/extra/mason/common/common.factor
+++ b/extra/mason/common/common.factor
@@ -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 -- )
diff --git a/extra/mason/notify/notify.factor b/extra/mason/notify/notify.factor
index 87447e48cc..122c8a47cd 100644
--- a/extra/mason/notify/notify.factor
+++ b/extra/mason/notify/notify.factor
@@ -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
diff --git a/extra/mason/report/report.factor b/extra/mason/report/report.factor
index 52237171cf..4a2138323c 100644
--- a/extra/mason/report/report.factor
+++ b/extra/mason/report/report.factor
@@ -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
diff --git a/extra/webapps/mason/download.xml b/extra/webapps/mason/download.xml
index 2b1bb76f64..af4ac0214d 100644
--- a/extra/webapps/mason/download.xml
+++ b/extra/webapps/mason/download.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>
diff --git a/extra/webapps/mason/mason.factor b/extra/webapps/mason/mason.factor
index 7e76de736d..4d42617520 100644
--- a/extra/webapps/mason/mason.factor
+++ b/extra/webapps/mason/mason.factor
@@ -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> ;