-! 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 ;
! 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?
! 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 [
- [
- "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 ;
+: status-notify ( report arg message -- )
+ [
+ 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 ;
+++ /dev/null
-Slava Pestov
\ No newline at end of file
+++ /dev/null
-! 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
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+ }
! 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> ;
<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>
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 ;
<protected>
"make releases" >>description
{ can-make-releases? } >>capabilities
+ "make-release" add-responder
- "make-release" add-responder ;
+ <status-update-action>
+ "status-update" add-responder ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! 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 ;
projects / factor.git / commitdiff