mason: use web service instead of shell script for status notifications, to scale better in the cloud
Slava Pestov
parent
fd7a304410
commit
1ae8cdc587
|
|
@ -1,4 +1,4 @@
|
|||
! 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: system io.files io.pathnames namespaces kernel accessors
|
||||
assocs ;
|
||||
|
|
@ -39,11 +39,11 @@ target-os get-global [
|
|||
! Keep test-log around?
|
||||
SYMBOL: builder-debug
|
||||
|
||||
! Host to send status notifications to.
|
||||
SYMBOL: status-host
|
||||
! URL for status notifications.
|
||||
SYMBOL: status-url
|
||||
|
||||
! Username to log in.
|
||||
SYMBOL: status-username
|
||||
! Password for status notifications.
|
||||
SYMBOL: status-secret
|
||||
|
||||
SYMBOL: upload-help?
|
||||
|
||||
|
|
|
|||
|
|
@ -1,57 +1,50 @@
|
|||
! 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
|
||||
mason.twitter namespaces sequences prettyprint fry ;
|
||||
USING: accessors fry http.client io io.encodings.utf8 io.files
|
||||
kernel mason.common mason.config mason.email mason.twitter
|
||||
namespaces prettyprint sequences ;
|
||||
IN: mason.notify
|
||||
|
||||
: status-notify ( input-file args -- )
|
||||
status-host get [
|
||||
: status-notify ( report arg message -- )
|
||||
[
|
||||
"ssh" , status-host get , "-l" , status-username get ,
|
||||
"./mason-notify" ,
|
||||
short-host-name ,
|
||||
target-cpu get ,
|
||||
target-os get ,
|
||||
] { } make prepend
|
||||
[ 5 ] 2dip '[
|
||||
<process>
|
||||
_ >>stdin
|
||||
_ >>command
|
||||
short-running-process
|
||||
] retry
|
||||
] [ 2drop ] if ;
|
||||
short-host-name "host-name" set
|
||||
target-cpu get "target-cpu" set
|
||||
target-os get "target-os" set
|
||||
status-secret get "secret" set
|
||||
"message" set
|
||||
"arg" set
|
||||
"report" set
|
||||
] H{ } make-assoc
|
||||
[ 5 ] dip '[ _ status-url get http-post 2drop ] retry ;
|
||||
|
||||
: notify-heartbeat ( -- )
|
||||
f { "heartbeat" } status-notify ;
|
||||
f 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 ]
|
||||
[ f swap "git-id" status-notify ]
|
||||
bi ;
|
||||
|
||||
: notify-make-vm ( -- )
|
||||
"Compiling VM" print flush
|
||||
f { "make-vm" } status-notify ;
|
||||
f f "make-vm" status-notify ;
|
||||
|
||||
: notify-boot ( -- )
|
||||
"Bootstrapping" print flush
|
||||
f { "boot" } status-notify ;
|
||||
f f "boot" status-notify ;
|
||||
|
||||
: notify-test ( -- )
|
||||
"Running tests" print flush
|
||||
f { "test" } status-notify ;
|
||||
f f "test" status-notify ;
|
||||
|
||||
: notify-report ( status -- )
|
||||
[ "Build finished with status: " write . flush ]
|
||||
[
|
||||
[ "report" ] dip
|
||||
[ [ utf8 file-contents ] dip email-report ]
|
||||
[ "report" swap name>> 2array status-notify ]
|
||||
2bi
|
||||
[ "report" utf8 file-contents ] dip
|
||||
[ name>> "report" status-notify ] [ email-report ] 2bi
|
||||
] bi ;
|
||||
|
||||
: notify-release ( archive-name -- )
|
||||
[ "Uploaded " prepend [ print flush ] [ mason-tweet ] bi ]
|
||||
[ f swap "release" swap 2array status-notify ]
|
||||
[ f swap "release" status-notify ]
|
||||
bi ;
|
||||
|
|
|
|||
|
|
@ -1 +0,0 @@
|
|||
Slava Pestov
|
||||
|
|
@ -1,80 +0,0 @@
|
|||
! Copyright (C) 2009, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors calendar combinators combinators.smart
|
||||
command-line db.tuples io io.encodings.utf8 io.files kernel
|
||||
mason.server namespaces present sequences ;
|
||||
IN: mason.server.notify
|
||||
|
||||
SYMBOLS: host-name target-os target-cpu message message-arg ;
|
||||
|
||||
: parse-args ( command-line -- )
|
||||
dup last message-arg set
|
||||
[
|
||||
{
|
||||
[ host-name set ]
|
||||
[ target-cpu set ]
|
||||
[ target-os set ]
|
||||
[ message set ]
|
||||
} spread
|
||||
] input<sequence ;
|
||||
|
||||
: find-builder ( -- builder )
|
||||
builder new
|
||||
host-name get >>host-name
|
||||
target-os get >>os
|
||||
target-cpu get >>cpu
|
||||
dup select-tuple [ ] [ dup insert-tuple ] ?if ;
|
||||
|
||||
: heartbeat ( builder -- ) now >>heartbeat-timestamp drop ;
|
||||
|
||||
: git-id ( builder id -- ) >>current-git-id +starting+ >>status drop ;
|
||||
|
||||
: make-vm ( builder -- ) +make-vm+ >>status drop ;
|
||||
|
||||
: boot ( builder -- ) +boot+ >>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
|
||||
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 -- )
|
||||
message get {
|
||||
{ "heartbeat" [ heartbeat ] }
|
||||
{ "git-id" [ message-arg get git-id ] }
|
||||
{ "make-vm" [ make-vm ] }
|
||||
{ "boot" [ boot ] }
|
||||
{ "test" [ test ] }
|
||||
{ "report" [ message-arg get contents report ] }
|
||||
{ "release" [ message-arg get release ] }
|
||||
} case ;
|
||||
|
||||
: handle-update ( command-line timestamp -- )
|
||||
[
|
||||
[ parse-args find-builder ] dip >>current-timestamp
|
||||
[ update-builder ] [ update-tuple ] bi
|
||||
] with-mason-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 now [ log-update ] [ handle-update ] 2bi ;
|
||||
|
||||
MAIN: main
|
||||
|
|
@ -17,8 +17,7 @@ clean-git-id clean-timestamp
|
|||
last-release release-git-id
|
||||
last-git-id last-timestamp last-report
|
||||
current-git-id current-timestamp
|
||||
status
|
||||
heartbeat-timestamp ;
|
||||
status ;
|
||||
|
||||
builder "BUILDERS" {
|
||||
{ "host-name" "HOST_NAME" TEXT +user-assigned-id+ }
|
||||
|
|
@ -39,8 +38,6 @@ 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> ;
|
||||
|
|
|
|||
|
|
@ -28,7 +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:label t:name="heartbeat-timestamp" /></td></tr>
|
||||
<tr><td>Last heartbeat:</td><td><t:label t:name="current-timestamp" /></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>
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ 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.downloads ;
|
||||
webapps.mason.downloads webapps.mason.status-update ;
|
||||
IN: webapps.mason
|
||||
|
||||
TUPLE: mason-app < dispatcher ;
|
||||
|
|
@ -35,5 +35,7 @@ can-make-releases? define-capability
|
|||
<protected>
|
||||
"make releases" >>description
|
||||
{ can-make-releases? } >>capabilities
|
||||
"make-release" add-responder
|
||||
|
||||
"make-release" add-responder ;
|
||||
<status-update-action>
|
||||
"status-update" add-responder ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,74 @@
|
|||
! Copyright (C) 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors calendar combinators db.tuples furnace.actions
|
||||
furnace.redirection html.forms http.server.responses io kernel
|
||||
mason.config mason.server namespaces validators ;
|
||||
IN: webapps.mason.status-update
|
||||
|
||||
: find-builder ( -- builder )
|
||||
builder new
|
||||
"host-name" value >>host-name
|
||||
"target-os" value >>os
|
||||
"target-cpu" value >>cpu
|
||||
dup select-tuple [ ] [ dup insert-tuple ] ?if ;
|
||||
|
||||
: git-id ( builder id -- ) >>current-git-id +starting+ >>status drop ;
|
||||
|
||||
: make-vm ( builder -- ) +make-vm+ >>status drop ;
|
||||
|
||||
: boot ( builder -- ) +boot+ >>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
|
||||
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 -- )
|
||||
"message" value {
|
||||
{ "heartbeat" [ drop ] }
|
||||
{ "git-id" [ "arg" value git-id ] }
|
||||
{ "make-vm" [ make-vm ] }
|
||||
{ "boot" [ boot ] }
|
||||
{ "test" [ test ] }
|
||||
{ "report" [ "arg" value "report" value report ] }
|
||||
{ "release" [ "arg" value release ] }
|
||||
} case ;
|
||||
|
||||
: <status-update-action> ( -- action )
|
||||
<action>
|
||||
[
|
||||
{
|
||||
{ "host-name" [ v-one-line ] }
|
||||
{ "target-cpu" [ v-one-line ] }
|
||||
{ "target-os" [ v-one-line ] }
|
||||
{ "message" [ v-one-line ] }
|
||||
{ "arg" [ [ v-one-line ] v-optional ] }
|
||||
{ "report" [ ] }
|
||||
{ "secret" [ v-one-line ] }
|
||||
} validate-params
|
||||
|
||||
"secret" value status-secret get = [ validation-failed ] unless
|
||||
] >>validate
|
||||
|
||||
[
|
||||
[
|
||||
[
|
||||
find-builder
|
||||
now >>current-timestamp
|
||||
[ update-builder ] [ update-tuple ] bi
|
||||
] with-mason-db
|
||||
"OK" "text/html" <content>
|
||||
] if-secure
|
||||
] >>submit ;
|
||||
Loading…
Reference in New Issue