steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Working on webapps.mason

db4
Slava Pestov 2009-05-21 00:08:43 -05:00
parent 2d81d082c6
commit 7d328011e8
7 changed files with 202 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/io/launcher/launcher.factor
View File

@ -264,7 +264,7 @@ M: output-process-error error.
: try-output-process ( command -- )
>process
+stdout+ >>stderr
+closed+ >>stdin
[ +closed+ or ] change-stdin
utf8 <process-reader*>
[ stream-contents ] [ dup wait-for-process ] bi*
0 = [ 2drop ] [ output-process-error ] if ;

11
extra/mason/common/common.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces sequences splitting system accessors
math.functions make io io.files io.pathnames io.directories
@ -13,10 +13,7 @@ SYMBOL: current-git-id
: short-running-process ( command -- )
#! Give network operations and shell commands at most
#! 15 minutes to complete, to catch hangs.
>process
15 minutes >>timeout
+closed+ >>stdin
try-output-process ;
>process 15 minutes >>timeout try-output-process ;
HOOK: really-delete-tree os ( path -- )
@ -45,10 +42,6 @@ M: unix really-delete-tree delete-tree ;
dup utf8 file-lines parse-fresh
[ "Empty file: " swap append throw ] [ nip first ] if-empty ;
: cat ( file -- ) utf8 file-contents print ;
: cat-n ( file n -- ) [ utf8 file-lines ] dip short tail* [ print ] each ;
: to-file ( object file -- ) utf8 [ . ] with-file-writer ;
: datestamp ( timestamp -- string )

6
extra/mason/notify/notify.factor
View File

@ -16,7 +16,7 @@ IN: mason.notify
] { } make prepend
[ 5 ] 2dip '[
<process>
_ [ +closed+ ] unless* >>stdin
_ >>stdin
_ >>command
short-running-process
] retry
@ -49,4 +49,6 @@ IN: mason.notify
] bi ;
: notify-release ( archive-name -- )
"Uploaded " prepend [ print flush ] [ mason-tweet ] bi ;
[ "Uploaded " prepend [ print flush ] [ mason-tweet ] bi ]
[ f swap "release" swap 2array status-notify ]
bi ;

55
extra/mason/notify/server/server.factor
View File

@ -1,26 +1,44 @@
! 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"
CONSTANT: +clean+ "status-clean"
CONSTANT: +dirty+ "status-dirty"
CONSTANT: +error+ "status-error"
TUPLE: builder host-name os cpu clean-git-id last-git-id last-report current-git-id status ;
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
@ -49,14 +67,23 @@ SYMBOLS: host-name target-os target-cpu message message-arg ;
: 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 -- )
@ -66,17 +93,25 @@ SYMBOLS: host-name target-os target-cpu message message-arg ;
{ "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

28
extra/mason/report/report.factor
View File

@ -59,13 +59,13 @@ IN: mason.report
"test-log" "Tests failed" failed-report ;
: timings-table ( -- xml )
{
$ boot-time-file
$ load-time-file
$ test-time-file
$ help-lint-time-file
$ benchmark-time-file
$ html-help-time-file
${
boot-time-file
load-time-file
test-time-file
help-lint-time-file
benchmark-time-file
html-help-time-file
} [
dup eval-file milli-seconds>time
[XML <tr><td><-></td><td><-></td></tr> XML]
@ -121,13 +121,13 @@ IN: mason.report
] with-report ;
: build-clean? ( -- ? )
{
[ load-all-vocabs-file eval-file empty? ]
[ test-all-vocabs-file eval-file empty? ]
[ help-lint-vocabs-file eval-file empty? ]
[ compiler-errors-file eval-file empty? ]
[ benchmark-error-vocabs-file eval-file empty? ]
} 0&& ;
${
load-all-vocabs-file
test-all-vocabs-file
help-lint-vocabs-file
compiler-errors-file
benchmark-error-vocabs-file
} [ eval-file empty? ] all? ;
: success ( -- status )
successful-report build-clean? status-clean status-dirty ? ;

23
extra/webapps/mason/download.xml Normal file
View File

@ -0,0 +1,23 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<html>
<head>
<title>Factor binary package for <t:label t:name="platform" /></title>
</head>
<body>
<h1>Factor binary package for <t:label t:name="platform" /></h1>
<p>Requirements:</p>
<t:xml t:name="requirements" />
<h2>Download <t:xml t:name="package" /></h2>
<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>
</body>
</html>
</t:chloe>

132
extra/webapps/mason/mason.factor
View File

@ -1,11 +1,28 @@
! 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 )
@ -20,24 +37,48 @@ IN: webapps.mason
[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 ] }
{ +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 ;
} case
] [ 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 ;
: 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 )
[ os>> ] [ cpu>> ] bi (platform) "http://downloads.factorcode.org/" prepend
dup [XML <a href=<->><-></a> XML] ;
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 )
{
@ -45,10 +86,12 @@ IN: webapps.mason
[ 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>
@ -60,6 +103,8 @@ IN: webapps.mason
<tr><td>Binaries:</td><td><-></td></tr>
<tr><td>Clean images:</td><td><-></td></tr>
</table>
<-> | <->
XML] ;
: machine-report ( -- xml )
@ -67,7 +112,7 @@ IN: webapps.mason
[ [ [ os>> ] [ cpu>> ] bi 2array ] compare ] sort
[ machine-table ] map ;
: build-farm-report ( -- xml )
: build-farm-summary ( -- xml )
recent-events
machine-report
[XML
@ -77,9 +122,52 @@ IN: webapps.mason
</html>
XML] ;
: <build-farm-report-action> ( -- action )
: <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 )
[
mason-db [ build-farm-report xml>string ] with-db
"text/html" <content>
] >>display ;
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> ;