Merge branch 'master' of git://factorcode.org/git/factor

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
+io.files io.launcher namespaces prettyprint combinators mason.child
-mason.common mason.help mason.release mason.report mason.email
+mason.cleanup mason.common mason.help mason.release mason.report
-mason.notify ;
+mason.email mason.notify ;
-IN: mason.build
-
 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
+    "factor" [ git-id ] with-directory {
         [ "git-id" to-file ]
+        [ "factor/git-id" to-file ]
         [ current-git-id set ]
         [ notify-begin-build ]
-    tri ;
+    } cleave ;
 
 : build ( -- )
     create-build-dir

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

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 -- )

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

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

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>
 

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,8 +86,7 @@ TUPLE: mason-app < dispatcher ;
     swap current-git-id>> git-link
     [XML <-> for <-> XML] ;
 
-: current-status ( builder -- xml )
+: status-string ( builder -- string )
-    [
     dup status>> {
         { +dirty+ [ drop "Dirty" ] }
         { +clean+ [ drop "Clean" ] }
@@ -47,8 +96,12 @@ TUPLE: mason-app < dispatcher ;
         { +boot+ [ "Bootstrapping" building ] }
         { +test+ [ "Testing" building ] }
         [ 2drop "Unknown" ]
-        } case
+    } case ;
-    ] [ current-timestamp>> present " (as of " ")" surround ] bi 2array ;
+
+: current-status ( builder -- xml )
+    [ 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
+    [ binaries-url ] [ last-release>> ] bi [ "/" glue ] keep link ;
-    [ 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 ;
+    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
+        current-builder {
             [ latest-binary-link "package" set-value ]
             [ release-git-id>> git-link "git-id" set-value ]
             [ requirements "requirements" set-value ]
-        tri
+            [ 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> ;