@@ -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 extra/mason/child/child.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 -- ) extra/mason/common/common.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 extra/mason/notify/notify.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 extra/mason/report/report.factor @@ -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> extra/webapps/mason/download.xml @@ -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> ; extra/webapps/mason/mason.factor 23ae3f4ab63edd3738479f823906847f3bd4dce8 c779fccd4d9e86ec0a970a2feeecfd36ba8d2fd1 Joe Groff arcata@gmail.com http://github.com/slavapestov/factor/commit/7178af55a75e5a73d2858bf752d4cfa52e94b236 7178af55a75e5a73d2858bf752d4cfa52e94b236 2009-05-21T18:55:57-07:00 2009-05-21T18:55:57-07:00 Merge branch 'master' of git://factorcode.org/git/factor 772a6d08e0c3903065991222a50375a73530f648 Joe Groff arcata@gmail.com