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/report/report.factor b/extra/mason/report/report.factor index 52237171cf..3ed332abf2 100644 --- a/extra/mason/report/report.factor +++ b/extra/mason/report/report.factor @@ -4,13 +4,16 @@ 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 +: short-host-name ( -- string ) + host-name "." split1 drop ; + : 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 @@

This package was built from GIT ID .

Once you download Factor, you can get started with the language.

+ +

Build machine information

+ + + + + + + + +
Host name:
Current status:
Last build:
Last clean build:
Binaries:
Clean images:
+ +

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 ><-> 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 <-> 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 <-> XML] ] map ] + [ + keys + cpus [ + [ nip second ] [ first ] 2bi [ + swap download-grid-cell + ] curry map [XML <-><-> XML] + ] with map + ] bi [XML <->
<->
XML] ; + +: ( -- action ) + + [ + download-grid + xml>string "text/html" + ] >>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" ] >>display ; -: log-file ( -- path ) home "mason.log" append-path ; - -: recent-events ( -- xml ) - log-file utf8 10 file-tail [XML 
<->
XML] ; - : git-link ( id -- link ) [ "http://github.com/slavapestov/factor/commit/" prepend ] keep [XML ><-> 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 ><-> XML] ; - : latest-binary-link ( builder -- xml ) - [ URL" download" ] dip - [ os>> "os" set-query-param ] - [ cpu>> "cpu" set-query-param ] bi - [XML >Latest download 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 >Latest build report 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 -

<-> / <->

- - - - - - - -
Host name:<->
Current status:<->
Last build:<->
Last clean build:<->
Binaries:<->
Clean images:<->
- - <-> | <-> - 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 - - Factor build farm -

Recent events

<->

Machine status

<-> - - XML] ; - -: ( -- action ) - - [ build-farm-summary xml>string "text/html" ] >>display ; - -TUPLE: builder-link href title ; - -C: builder-link - : requirements ( builder -- xml ) [ os>> { @@ -141,7 +138,7 @@ C: 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 ] bi 2array sift [ [XML
  • <->
    • XML] ] map [XML
      <->
    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 ; + : ( -- 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 ; : ( -- dispatcher ) mason-app new-dispatcher - "" add-responder "report" add-responder "download" add-responder + "grid" add-responder mason-db ;