! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators combinators.smart command-line db
-db.sqlite db.tuples db.types io kernel namespaces sequences ;
+db.sqlite db.tuples db.types io io.encodings.utf8 io.files
+present kernel namespaces sequences calendar ;
IN: mason.notify.server
CONSTANT: +starting+ "starting"
CONSTANT: +make-vm+ "make-vm"
CONSTANT: +boot+ "boot"
CONSTANT: +test+ "test"
-CONSTANT: +clean+ "clean"
-CONSTANT: +dirty+ "dirty"
-
-TUPLE: builder host-name os cpu clean-git-id last-git-id last-report current-git-id status ;
+CONSTANT: +clean+ "status-clean"
+CONSTANT: +dirty+ "status-dirty"
+CONSTANT: +error+ "status-error"
+
+TUPLE: builder
+host-name os cpu
+clean-git-id clean-timestamp
+last-release release-git-id
+last-git-id last-timestamp last-report
+current-git-id current-timestamp
+status ;
builder "BUILDERS" {
{ "host-name" "HOST_NAME" TEXT +user-assigned-id+ }
{ "os" "OS" TEXT +user-assigned-id+ }
{ "cpu" "CPU" TEXT +user-assigned-id+ }
+
{ "clean-git-id" "CLEAN_GIT_ID" TEXT }
+ { "clean-timestamp" "CLEAN_TIMESTAMP" TIMESTAMP }
+
+ { "last-release" "LAST_RELEASE" TEXT }
+ { "release-git-id" "RELEASE_GIT_ID" TEXT }
+
{ "last-git-id" "LAST_GIT_ID" TEXT }
+ { "last-timestamp" "LAST_TIMESTAMP" TIMESTAMP }
{ "last-report" "LAST_REPORT" TEXT }
+
{ "current-git-id" "CURRENT_GIT_ID" TEXT }
+ ! Can't name it CURRENT_TIMESTAMP because of bug in db library
+ { "current-timestamp" "CURR_TIMESTAMP" TIMESTAMP }
{ "status" "STATUS" TEXT }
} define-persistent
: make-vm ( builder -- ) +make-vm+ >>status drop ;
-: boot ( report -- ) +boot+ >>status drop ;
+: boot ( builder -- ) +boot+ >>status drop ;
-: test ( report -- ) +test+ >>status drop ;
+: test ( builder -- ) +test+ >>status drop ;
: report ( builder status content -- )
[ >>status ] [ >>last-report ] bi*
- dup status>> +clean+ = [ dup current-git-id>> >>clean-git-id ] when
+ dup status>> +clean+ = [
+ dup current-git-id>> >>clean-git-id
+ dup current-timestamp>> >>clean-timestamp
+ ] when
dup current-git-id>> >>last-git-id
+ dup current-timestamp>> >>last-timestamp
+ drop ;
+
+: release ( builder name -- )
+ >>last-release
+ dup clean-git-id>> >>release-git-id
drop ;
: update-builder ( builder -- )
{ "boot" [ boot ] }
{ "test" [ test ] }
{ "report" [ message-arg get contents report ] }
+ { "release" [ message-arg get release ] }
} case ;
: mason-db ( -- db ) "resource:mason.db" <sqlite-db> ;
-: handle-update ( command-line -- )
+: handle-update ( command-line timestamp -- )
mason-db [
- parse-args find-builder
+ [ parse-args find-builder ] dip >>current-timestamp
[ update-builder ] [ update-tuple ] bi
] with-db ;
+CONSTANT: log-file "resource:mason.log"
+
+: log-update ( command-line timestamp -- )
+ log-file utf8 [
+ present write ": " write " " join print
+ ] with-file-appender ;
+
: main ( -- )
- command-line get handle-update ;
+ command-line get now [ log-update ] [ handle-update ] 2bi ;
MAIN: main
! 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
-mason.report math.order sequences sorting splitting xml.syntax
-xml.writer io.pathnames io.encodings.utf8 io.files ;
+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 ;
IN: webapps.mason
+TUPLE: mason-app < dispatcher ;
+
+: validate-os/cpu ( -- )
+ {
+ { "os" [ v-one-line ] }
+ { "cpu" [ v-one-line ] }
+ } validate-params ;
+
+: current-builder ( -- builder )
+ builder new "os" value >>os "cpu" value >>cpu select-tuple ;
+
+: <build-report-action> ( -- action )
+ <action>
+ [ validate-os/cpu ] >>init
+ [ current-builder last-report>> "text/html" <content> ] >>display ;
+
: log-file ( -- path ) home "mason.log" append-path ;
: recent-events ( -- xml )
[XML <-> for <-> XML] ;
: current-status ( builder -- xml )
- dup status>> {
- { "status-dirty" [ drop "Dirty" ] }
- { "status-clean" [ drop "Clean" ] }
- { "status-error" [ drop "Error" ] }
- { "starting" [ "Starting" building ] }
- { "make-vm" [ "Compiling VM" building ] }
- { "boot" [ "Bootstrapping" building ] }
- { "test" [ "Testing" building ] }
- [ 2drop "Unknown" ]
- } case ;
+ [
+ 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 ;
-: binaries-link ( builder -- link )
- [ os>> ] [ cpu>> ] bi (platform) "http://downloads.factorcode.org/" prepend
+: build-status ( git-id timestamp -- xml )
+ over [ [ git-link ] [ present ] bi* " (built on " ")" surround 2array ] [ 2drop f ] if ;
+
+: 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-link ( builder -- link )
+ binaries-url url-link ;
+
+: clean-image-url ( builder -- url )
+ [ os>> ] [ cpu>> ] bi (platform) "http://factorcode.org/images/clean/" prepend ;
+
: clean-image-link ( builder -- link )
- [ os>> ] [ cpu>> ] bi (platform) "http://factorcode.org/images/clean/" prepend
- dup [XML <a href=<->><-></a> XML] ;
+ clean-image-url url-link ;
+
+: report-link ( builder -- xml )
+ [ URL" report" ] dip
+ [ os>> "os" set-query-param ]
+ [ cpu>> "cpu" set-query-param ] bi
+ [XML <a href=<->>Latest build report</a> XML] ;
: machine-table ( builder -- xml )
{
[ cpu>> ]
[ host-name>> "." split1 drop ]
[ current-status ]
- [ last-git-id>> dup [ git-link ] when ]
- [ clean-git-id>> dup [ git-link ] when ]
+ [ [ 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>
<tr><td>Binaries:</td><td><-></td></tr>
<tr><td>Clean images:</td><td><-></td></tr>
</table>
+
+ <-> | <->
XML] ;
: machine-report ( -- xml )
[ [ [ os>> ] [ cpu>> ] bi 2array ] compare ] sort
[ machine-table ] map ;
-: build-farm-report ( -- xml )
+: build-farm-summary ( -- xml )
recent-events
machine-report
[XML
</html>
XML] ;
-: <build-farm-report-action> ( -- action )
+: <summary-action> ( -- action )
<action>
- [
- mason-db [ build-farm-report xml>string ] with-db
- "text/html" <content>
- ] >>display ;
\ No newline at end of file
+ [ build-farm-summary xml>string "text/html" <content> ] >>display ;
+
+TUPLE: builder-link href title ;
+
+C: <builder-link> builder-link
+
+: requirements ( builder -- xml )
+ [
+ os>> {
+ { "winnt" "Windows XP (also tested on Vista)" }
+ { "macosx" "Mac OS X 10.5 Leopard" }
+ { "linux" "Linux 2.6.16 with GLIBC 2.4" }
+ { "freebsd" "FreeBSD 7.0" }
+ { "netbsd" "NetBSD 4.0" }
+ { "openbsd" "OpenBSD 4.2" }
+ } at
+ ] [
+ 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" ] }
+ { [ t ] [ drop f ] }
+ } cond
+ ] [ drop f ] if
+ ] bi
+ 2array sift [ [XML <li><-></li> XML] ] map [XML <ul><-></ul> XML] ;
+
+: <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
+ ] >>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
+ mason-db <db-persistence> ;
+
projects / factor.git / commitdiff