mason: big overhaul

- add heartbeats for eventual notification of when build machines go down
- mason.version: replaces mason.release, builds source package automatically, and tweets when new versions released
- webapps.mason: new downloads action includes automatically-generated source download and release announcement links
release
Slava Pestov 2010-04-11 18:42:12 -07:00
parent 956ffa8946
commit 89560ee4d9
33 changed files with 347 additions and 175 deletions

View File

@ -6,6 +6,6 @@ USING: mason.email mason.common mason.config namespaces tools.test ;
"linux" target-os set
"x86.64" target-cpu set
"12345" current-git-id set
status-error subject prefix-subject
status-error report-subject
] with-scope
] unit-test

View File

@ -1,35 +1,42 @@
! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
! Copyright (C) 2008, 2010 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces accessors combinators make smtp debugger
prettyprint sequences io io.streams.string io.encodings.utf8 io.files
io.sockets mason.common mason.platform mason.config ;
IN: mason.email
: prefix-subject ( str -- str' )
[ "mason on " % platform % ": " % % ] "" make ;
: email-status ( body content-type subject -- )
: mason-email ( body content-type subject -- )
<email>
builder-from get >>from
builder-recipients get >>to
swap prefix-subject >>subject
swap >>subject
swap >>content-type
swap >>body
send-email ;
: subject ( status -- str )
[ current-git-id get 7 short head " -- " ] dip {
: subject-prefix ( -- string )
"mason on " platform ": " 3append ;
: report-subject ( status -- string )
[
subject-prefix %
current-git-id get 7 short head %
" -- " %
{
{ status-clean [ "clean" ] }
{ status-dirty [ "dirty" ] }
{ status-error [ "error" ] }
} case 3append ;
} case %
] "" make ;
: email-report ( report status -- )
[ "text/html" ] dip subject email-status ;
[ "text/html" ] dip report-subject mason-email ;
: email-error ( error callstack -- )
[
"Fatal error on " write host-name print nl
[ error. ] [ callstack. ] bi*
] with-string-writer "text/plain" "fatal error"
email-status ;
] with-string-writer
"text/plain"
subject-prefix "fatal error" append
mason-email ;

View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
! Copyright (C) 2008, 2010 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors calendar continuations debugger io
io.directories io.files kernel mason.common
mason.email mason.updates namespaces threads ;
mason.email mason.updates mason.notify namespaces threads ;
FROM: mason.build => build ;
IN: mason
@ -15,6 +15,7 @@ IN: mason
error. flush ;
: build-loop ( -- )
notify-heartbeat
?prepare-build-machine
[
[

View File

@ -1,4 +1,4 @@
! Copyright (C) 2009 Slava Pestov.
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays accessors io io.sockets io.encodings.utf8 io.files
io.launcher kernel make mason.config mason.common mason.email
@ -22,6 +22,9 @@ IN: mason.notify
] retry
] [ 2drop ] if ;
: notify-heartbeat ( -- )
f { "heartbeat" } status-notify ;
: notify-begin-build ( git-id -- )
[ "Starting build of GIT ID " write print flush ]
[ f swap "git-id" swap 2array status-notify ]

View File

@ -25,6 +25,9 @@ SYMBOLS: host-name target-os target-cpu message message-arg ;
target-cpu get >>cpu
dup select-tuple [ ] [ dup insert-tuple ] ?if ;
: heartbeat ( -- )
now >>heartbeat-timestamp ;
: git-id ( builder id -- )
>>current-git-id +starting+ >>status drop ;
@ -51,6 +54,7 @@ SYMBOLS: host-name target-os target-cpu message message-arg ;
: update-builder ( builder -- )
message get {
{ "heartbeat" [ heartbeat ] }
{ "git-id" [ message-arg get git-id ] }
{ "make-vm" [ make-vm ] }
{ "boot" [ boot ] }

View File

@ -1 +0,0 @@
Slava Pestov

View File

@ -1,82 +0,0 @@
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors calendar db db.tuples db.types grouping io
io.encodings.ascii io.launcher kernel locals make
mason.release.archive mason.config mason.platform mason.server
namespaces sequences ;
IN: mason.server.release
: platform ( builder -- string )
[ os>> ] [ cpu>> ] bi (platform) ;
: package-name ( builder -- string )
[ platform ] [ last-release>> ] bi "/" glue ;
: release-name ( version builder -- string )
[
"releases/" %
over % "/" %
[ "factor-" % platform % "-" % % ]
[ os>> extension % ]
bi
] "" make ;
: release-command ( version builder -- command )
[
"cp " %
[ nip package-name % " " % ] [ release-name % ] 2bi
] "" make ;
TUPLE: release
host-name os cpu
last-release release-git-id ;
release "RELEASES" {
{ "host-name" "HOST_NAME" TEXT +user-assigned-id+ }
{ "os" "OS" TEXT +user-assigned-id+ }
{ "cpu" "CPU" TEXT +user-assigned-id+ }
{ "last-release" "LAST_RELEASE" TEXT }
{ "release-git-id" "RELEASE_GIT_ID" TEXT }
} define-persistent
:: <release> ( version builder -- release )
release new
builder host-name>> >>host-name
builder os>> >>os
builder cpu>> >>cpu
builder release-git-id>> >>release-git-id
version builder release-name >>last-release ;
: execute-on-server ( string -- )
[ "ssh" , upload-host get , "-l" , upload-username get , ] { } make
<process>
swap >>command
5 minutes >>timeout
ascii [ write ] with-process-writer ;
: release-script ( version builders -- string )
[ upload-directory get "cd " "\n" surround ] 2dip
[ release-command ] with map "\n" join
append ;
: create-releases ( version builders -- )
release-script execute-on-server ;
: update-releases ( version builders -- )
[
release new delete-tuples
[ <release> insert-tuple ] with each
] with-transaction ;
: check-releases ( builders -- )
[ release-git-id>> ] map all-equal?
[ "Not all builders are up to date" throw ] unless ;
: do-release ( version -- )
[
builder new select-tuples
[ nip check-releases ]
[ create-releases ]
[ update-releases ]
2tri
] with-mason-db ;

View File

@ -17,7 +17,8 @@ clean-git-id clean-timestamp
last-release release-git-id
last-git-id last-timestamp last-report
current-git-id current-timestamp
status ;
status
heartbeat-timestamp ;
builder "BUILDERS" {
{ "host-name" "HOST_NAME" TEXT +user-assigned-id+ }
@ -38,6 +39,8 @@ builder "BUILDERS" {
! Can't name it CURRENT_TIMESTAMP because of bug in db library
{ "current-timestamp" "CURR_TIMESTAMP" TIMESTAMP }
{ "status" "STATUS" TEXT }
{ "heartbeat-timestamp" "HEARTBEAT_TIMESTAMP" TIMESTAMP }
} define-persistent
: mason-db ( -- db ) "resource:mason.db" <sqlite-db> ;

View File

@ -1 +0,0 @@
Slava Pestov

View File

@ -1,49 +0,0 @@
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image bootstrap.image.download io io.directories
io.directories.hierarchy io.files.unique io.launcher
io.pathnames kernel sequences namespaces mason.common mason.config ;
IN: mason.source
: clone-factor ( -- )
{ "git" "clone" } home "factor" append-path suffix try-process ;
: save-git-id ( -- )
git-id "git-id" to-file ;
: delete-git-tree ( -- )
".git" delete-tree ;
: download-images ( -- )
images [ download-image ] each ;
: prepare-source ( -- )
"factor" [ save-git-id delete-git-tree download-images ] with-directory ;
: package-name ( version -- string )
"factor-src-" ".zip" surround ;
: make-tarball ( version -- path )
[ { "zip" "-qr9" } ] dip package-name
[ suffix "factor" suffix try-process ] keep ;
: make-package ( version -- path )
unique-directory
[
clone-factor prepare-source make-tarball
"Package created: " write absolute-path dup print
] with-directory ;
: remote-location ( version -- dest )
[ upload-directory get "/releases/" ] dip 3append ;
: remote-archive-name ( version -- dest )
[ remote-location ] [ package-name ] bi "/" glue ;
: upload-package ( package version -- )
[ upload-username get upload-host get ] dip
remote-archive-name
upload-safely ;
: release-source-package ( version -- )
[ make-package ] [ upload-package ] bi ;

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -0,0 +1,20 @@
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io kernel make mason.version.common mason.version.files
sequences ;
IN: mason.version.binary
: binary-release-command ( version builder -- command )
[
"cp " %
[ nip binary-package-name % " " % ]
[ remote-binary-release-name % ]
2bi
] "" make ;
: binary-release-script ( version builders -- string )
[ binary-release-command ] with map "\n" join ;
: do-binary-release ( version builders -- )
"Copying binary releases to release directory..." print flush
binary-release-script execute-on-server ;

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -0,0 +1,12 @@
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors calendar io io.encodings.ascii io.launcher
kernel make mason.config namespaces ;
IN: mason.version.common
: execute-on-server ( string -- )
[ "ssh" , upload-host get , "-l" , upload-username get , ] { } make
<process>
swap >>command
5 minutes >>timeout
ascii [ write ] with-process-writer ;

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -0,0 +1,54 @@
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors calendar db db.tuples db.types kernel locals
mason.version.files sequences ;
IN: mason.version.data
TUPLE: release
host-name os cpu
last-release release-git-id ;
release "RELEASES" {
{ "host-name" "HOST_NAME" TEXT +user-assigned-id+ }
{ "os" "OS" TEXT +user-assigned-id+ }
{ "cpu" "CPU" TEXT +user-assigned-id+ }
{ "last-release" "LAST_RELEASE" TEXT }
{ "release-git-id" "RELEASE_GIT_ID" TEXT }
} define-persistent
:: <release> ( version builder -- release )
release new
builder host-name>> >>host-name
builder os>> >>os
builder cpu>> >>cpu
builder release-git-id>> >>release-git-id
version builder binary-release-name >>last-release ;
: update-binary-releases ( version builders -- )
[
release new delete-tuples
[ <release> insert-tuple ] with each
] with-transaction ;
TUPLE: version
id version git-id timestamp source-path announcement-url ;
version "VERSIONS" {
{ "id" "ID" INTEGER +db-assigned-id+ }
{ "version" "VERSION" TEXT }
{ "git-id" "GIT_ID" TEXT }
{ "timestamp" "TIMESTAMP" TIMESTAMP }
{ "source-path" "SOURCE_PATH" TEXT }
{ "announcement-url" "ANNOUNCEMENT_URL" TEXT }
} define-persistent
: update-version ( version git-id announcement-url -- )
version new
swap >>announcement-url
swap >>git-id
swap [ >>version ] [ source-release-name >>source-path ] bi
now >>timestamp
insert-tuple ;
: latest-version ( -- version )
version new select-tuples last ;

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -0,0 +1,39 @@
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors fry kernel make mason.config mason.platform
mason.release.archive namespaces sequences ;
IN: mason.version.files
: release-directory ( string version -- string )
[ "releases/" % % "/" % % ] "" make ;
: remote-directory ( string -- string' )
[ upload-directory get ] dip "/" glue ;
: remote ( string version -- string )
remote-directory swap "/" glue ;
: platform ( builder -- string )
[ os>> ] [ cpu>> ] bi (platform) ;
: binary-package-name ( builder -- string )
[ [ platform % "/" % ] [ last-release>> % ] bi ] "" make
remote-directory ;
: binary-release-name ( version builder -- string )
[
[
[ "factor-" % platform % "-" % % ]
[ os>> extension % ]
bi
] "" make
] [ drop ] 2bi release-directory ;
: remote-binary-release-name ( version builder -- string )
[ binary-release-name ] [ drop ] 2bi remote ;
: source-release-name ( version -- string )
[ "factor-src-" ".zip" surround ] keep release-directory ;
: remote-source-release-name ( version -- string )
[ source-release-name ] keep remote ;

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -0,0 +1,51 @@
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image bootstrap.image.download io
io.directories io.directories.hierarchy io.files.unique
io.launcher io.pathnames kernel mason.common mason.config
mason.version.files namespaces sequences ;
IN: mason.version.source
: clone-factor ( -- )
{ "git" "clone" "git://factorcode.org/git/factor.git" } try-process ;
: git-reset ( git-id -- )
{ "git" "reset" "--hard" } swap suffix try-process ;
: save-git-id ( git-id -- )
"git-id" to-file ;
: delete-git-tree ( -- )
".git" delete-tree
".gitignore" delete-file ;
: download-images ( -- )
images [ download-image ] each ;
: prepare-source ( git-id -- )
"factor" [
[ git-reset ] [ save-git-id ] bi
delete-git-tree
download-images
] with-directory ;
: (make-source-release) ( version -- path )
[ { "zip" "-qr9" } ] dip source-release-name file-name
[ suffix "factor" suffix try-process ] keep ;
: make-source-release ( version git-id -- path )
"Creating source release..." print flush
unique-directory
[
clone-factor prepare-source (make-source-release)
"Package created: " write absolute-path dup print
] with-directory ;
: upload-source-release ( package version -- )
"Uploading source release..." print flush
[ upload-username get upload-host get ] dip
remote-source-release-name
upload-safely ;
: do-source-release ( version git-id -- )
[ make-source-release ] [ drop upload-source-release ] 2bi ;

View File

@ -0,0 +1,52 @@
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors bit.ly combinators db.tuples debugger fry
grouping io io.streams.string kernel locals make mason.email
mason.server mason.twitter mason.version.binary
mason.version.common mason.version.data mason.version.files
mason.version.source sequences threads ;
IN: mason.version
: check-releases ( builders -- )
[ release-git-id>> ] map all-equal?
[ "Some builders are out of date" throw ] unless ;
: make-release-directory ( version -- )
"Creating release directory..." print flush
[ "mkdir -p " % "" release-directory % "\n" % ] "" make
execute-on-server ;
: tweet-release ( version announcement-url -- )
[
"Factor " %
[ % " released -- " % ] [ shorten-url % ] bi*
] "" make mason-tweet ;
:: (do-release) ( version announcement-url -- )
[
builder new select-tuples :> builders
builders first release-git-id>> :> git-id
builders check-releases
version make-release-directory
version builders do-binary-release
version builders update-binary-releases
version git-id do-source-release
version git-id announcement-url update-version
version announcement-url tweet-release
"Done." print flush
] with-mason-db ;
: send-release-email ( string version -- )
[ "text/plain" ] dip "Release output: " prepend mason-email ;
:: do-release ( version announcement-url -- )
[
[
[
version announcement-url (do-release)
] try
] with-string-writer
version send-release-email
] "Mason release" spawn drop ;

View File

@ -28,6 +28,7 @@
<table border="1">
<tr><td>Host name:</td><td><t:xml t:name="host-name" /></td></tr>
<tr><td>Last heartbeat:</td><td><t:xml t:name="last-heartbeat" /></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>

View File

@ -0,0 +1,22 @@
<?xml version='1.0' ?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<h2>Stable release: <t:link t:name="stable-release" /></h2>
<table id="mytable" cellspacing="0" summary="Stable releases">
<t:xml t:name="release-grid" />
</table>
<p><b>Source code</b>: <t:link t:name="source-release" /></p>
<h2>Development release</h2>
<table id="mytable" cellspacing="0" summary="Development releases">
<t:xml t:name="package-grid" />
</table>
</t:chloe>

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -0,0 +1,25 @@
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors furnace.actions html.components html.forms
kernel mason.server mason.version.data webapps.mason.grids
webapps.mason.utils ;
IN: webapps.mason.downloads
: stable-release ( version -- link )
[ version>> ] [ announcement-url>> ] bi <simple-link> ;
: source-release ( version -- link )
[ version>> ] [ source-path>> download-url ] bi <simple-link> ;
: <downloads-action> ( -- action )
<page-action>
[
[
package-grid "package-grid" set-value
release-grid "release-grid" set-value
latest-version
[ stable-release "stable-release" set-value ]
[ source-release "source-release" set-value ] bi
] with-mason-db
] >>init ;

View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs db.tuples furnace.actions
furnace.utilities http.server.responses kernel locals
mason.server mason.server.release sequences splitting urls
mason.server mason.version.data sequences splitting urls
webapps.mason.utils xml.syntax xml.writer ;
IN: webapps.mason.grids
@ -19,7 +19,6 @@ CONSTANT: oses
{ "macosx" "Mac OS X" }
{ "linux" "Linux" }
{ "freebsd" "FreeBSD" }
{ "netbsd" "NetBSD" }
{ "openbsd" "OpenBSD" }
}

View File

@ -11,8 +11,12 @@
</head>
<body>
<t:form t:action="$mason-app/make-release">
Version: <t:field t:name="version" />
<button type="submit">Go</button>
<table>
<tr><td>Version:</td><td><t:field t:name="version" /></td></tr>
<tr><td>Announcement URL:</td><td><t:field t:name="announcement-url" /></td></tr>
</table>
<p><button type="submit">Go</button></p>
</t:form>
</body>
</html>

View File

@ -1,8 +1,7 @@
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors furnace.actions html.forms
http.server.responses mason.server mason.server.release
validators ;
http.server.responses mason.server mason.version validators ;
IN: webapps.mason.make-release
: <make-release-action> ( -- action )
@ -10,7 +9,7 @@ IN: webapps.mason.make-release
[ { { "version" [ v-one-line ] } } validate-params ] >>validate
[
[
"version" value do-release
"version" value "announcement-url" value do-release
"OK" "text/html" <content>
] with-mason-db
] >>submit ;

View File

@ -3,7 +3,8 @@
USING: accessors furnace.auth furnace.db
http.server.dispatchers mason.server webapps.mason.grids
webapps.mason.make-release webapps.mason.package
webapps.mason.release webapps.mason.report ;
webapps.mason.release webapps.mason.report
webapps.mason.downloads ;
IN: webapps.mason
TUPLE: mason-app < dispatcher ;
@ -21,19 +22,16 @@ can-make-releases? define-capability
{ mason-app "download-package" } >>template
"package" add-responder
<package-grid-action>
"packages" add-responder
<download-release-action>
{ mason-app "download-release" } >>template
"release" add-responder
<release-grid-action>
"releases" add-responder
<downloads-action>
{ mason-app "downloads" } >>template
"downloads" add-responder
<make-release-action>
{ mason-app "make-release" } >>template
<protected>
"make releases" >>description
{ can-make-releases? } >>capabilities

View File

@ -2,8 +2,9 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators furnace.actions html.forms
kernel mason.platform mason.report mason.server present
sequences webapps.mason webapps.mason.report
webapps.mason.utils xml.syntax ;
sequences webapps.mason webapps.mason.report webapps.mason.utils
xml.syntax ;
FROM: mason.version.files => platform ;
IN: webapps.mason.package
: building ( builder string -- xml )
@ -31,7 +32,7 @@ IN: webapps.mason.package
over [ [ git-link ] [ present ] bi* " (built on " ")" surround 2array ] [ 2drop f ] if ;
: packages-url ( builder -- url )
[ os>> ] [ cpu>> ] bi (platform) "http://downloads.factorcode.org/" prepend ;
platform download-url ;
: package-link ( builder -- xml )
[ packages-url ] [ last-release>> ] bi [ "/" glue ] keep link ;
@ -40,7 +41,7 @@ IN: webapps.mason.package
packages-url dup link ;
: clean-image-url ( builder -- url )
[ os>> ] [ cpu>> ] bi (platform) "http://factorcode.org/images/clean/" prepend ;
platform "http://factorcode.org/images/clean/" prepend ;
: clean-image-link ( builder -- link )
clean-image-url dup link ;
@ -65,6 +66,7 @@ IN: webapps.mason.package
[ current-status "status" set-value ]
[ last-build-status "last-build" set-value ]
[ clean-build-status "last-clean-build" set-value ]
[ heartbeat-timestamp>> "heartbeat-timestamp" set-value ]
[ packages-link "binaries" set-value ]
[ clean-image-link "clean-images" set-value ]
[ report-link "last-report" set-value ]

View File

@ -6,8 +6,7 @@ webapps.mason.utils io.pathnames ;
IN: webapps.mason.release
: release-link ( builder -- xml )
[ "http://downloads.factorcode.org/" ] dip
last-release>> [ "/" glue ] [ file-name ] bi link ;
last-release>> [ download-url ] [ file-name ] bi link ;
: <download-release-action> ( -- action )
<page-action>

View File

@ -1,7 +1,7 @@
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs db.tuples furnace.actions
html.forms kernel mason.server mason.server.release sequences
html.forms kernel mason.server mason.version.data sequences
validators xml.syntax ;
IN: webapps.mason.utils
@ -38,3 +38,6 @@ IN: webapps.mason.utils
] [ drop f ] if
] bi
2array sift [ [XML <li><-></li> XML] ] map [XML <ul><-></ul> XML] ;
: download-url ( string -- string' )
"http://downloads.factorcode.org/" prepend ;