2009-05-13 20:39:26 -04:00
|
|
|
! Copyright (C) 2009 Slava Pestov.
|
|
|
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
|
|
|
USING: accessors arrays combinators db db.tuples furnace.actions
|
|
|
|
|
http.server.responses kernel mason.platform mason.notify.server
|
2009-05-19 18:56:34 -04:00
|
|
|
mason.report math.order sequences sorting splitting xml.syntax
|
|
|
|
|
xml.writer io.pathnames io.encodings.utf8 io.files ;
|
2009-05-13 20:39:26 -04:00
|
|
|
IN: webapps.mason
|
|
|
|
|
|
2009-05-13 20:53:52 -04:00
|
|
|
: log-file ( -- path ) home "mason.log" append-path ;
|
|
|
|
|
|
|
|
|
|
: recent-events ( -- xml )
|
2009-05-19 18:46:05 -04:00
|
|
|
log-file utf8 10 file-tail [XML <pre><-></pre> XML] ;
|
2009-05-13 20:53:52 -04:00
|
|
|
|
2009-05-13 20:39:26 -04:00
|
|
|
: git-link ( id -- link )
|
|
|
|
|
[ "http://github.com/slavapestov/factor/commit/" prepend ] keep
|
|
|
|
|
[XML <a href=<->><-></a> XML] ;
|
|
|
|
|
|
|
|
|
|
: building ( builder string -- xml )
|
|
|
|
|
swap current-git-id>> git-link
|
|
|
|
|
[XML <-> for <-> XML] ;
|
|
|
|
|
|
|
|
|
|
: current-status ( builder -- xml )
|
|
|
|
|
dup status>> {
|
2009-05-19 18:46:05 -04:00
|
|
|
{ "status-dirty" [ drop "Dirty" ] }
|
|
|
|
|
{ "status-clean" [ drop "Clean" ] }
|
|
|
|
|
{ "status-error" [ drop "Error" ] }
|
2009-05-13 20:39:26 -04:00
|
|
|
{ "starting" [ "Starting" building ] }
|
|
|
|
|
{ "make-vm" [ "Compiling VM" building ] }
|
|
|
|
|
{ "boot" [ "Bootstrapping" building ] }
|
|
|
|
|
{ "test" [ "Testing" building ] }
|
|
|
|
|
[ 2drop "Unknown" ]
|
|
|
|
|
} case ;
|
|
|
|
|
|
|
|
|
|
: binaries-link ( builder -- link )
|
|
|
|
|
[ os>> ] [ cpu>> ] bi (platform) "http://downloads.factorcode.org/" prepend
|
|
|
|
|
dup [XML <a href=<->><-></a> XML] ;
|
|
|
|
|
|
|
|
|
|
: clean-image-link ( builder -- link )
|
|
|
|
|
[ os>> ] [ cpu>> ] bi (platform) "http://factorcode.org/images/clean/" prepend
|
|
|
|
|
dup [XML <a href=<->><-></a> XML] ;
|
|
|
|
|
|
|
|
|
|
: machine-table ( builder -- xml )
|
|
|
|
|
{
|
|
|
|
|
[ os>> ]
|
|
|
|
|
[ cpu>> ]
|
|
|
|
|
[ host-name>> "." split1 drop ]
|
|
|
|
|
[ current-status ]
|
|
|
|
|
[ last-git-id>> dup [ git-link ] when ]
|
|
|
|
|
[ clean-git-id>> dup [ git-link ] when ]
|
|
|
|
|
[ binaries-link ]
|
|
|
|
|
[ clean-image-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] ;
|
|
|
|
|
|
2009-05-13 20:53:52 -04:00
|
|
|
: machine-report ( -- xml )
|
|
|
|
|
builder new select-tuples
|
|
|
|
|
[ [ [ os>> ] [ cpu>> ] bi 2array ] compare ] sort
|
|
|
|
|
[ machine-table ] map ;
|
|
|
|
|
|
|
|
|
|
: build-farm-report ( -- xml )
|
|
|
|
|
recent-events
|
|
|
|
|
machine-report
|
2009-05-13 20:39:26 -04:00
|
|
|
[XML
|
2009-05-13 20:53:52 -04:00
|
|
|
<html>
|
|
|
|
|
<head><title>Factor build farm</title></head>
|
|
|
|
|
<body><h1>Recent events</h1><-> <h1>Machine status</h1><-></body>
|
|
|
|
|
</html>
|
2009-05-13 20:39:26 -04:00
|
|
|
XML] ;
|
|
|
|
|
|
2009-05-13 20:55:33 -04:00
|
|
|
: <build-farm-report-action> ( -- action )
|
2009-05-13 20:39:26 -04:00
|
|
|
<action>
|
|
|
|
|
[
|
2009-05-13 20:53:52 -04:00
|
|
|
mason-db [ build-farm-report xml>string ] with-db
|
2009-05-13 20:39:26 -04:00
|
|
|
"text/html" <content>
|
|
|
|
|
] >>display ;
|
