diff --git a/extra/mason/config/config.factor b/extra/mason/config/config.factor index 5ec44df0a9..48f4d307c8 100644 --- a/extra/mason/config/config.factor +++ b/extra/mason/config/config.factor @@ -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? diff --git a/extra/mason/notify/notify.factor b/extra/mason/notify/notify.factor index d7319c0f20..144f0de122 100644 --- a/extra/mason/notify/notify.factor +++ b/extra/mason/notify/notify.factor @@ -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 [ - [ - "ssh" , status-host get , "-l" , status-username get , - "./mason-notify" , - short-host-name , - target-cpu get , - target-os get , - ] { } make prepend - [ 5 ] 2dip '[ - - _ >>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 ; diff --git a/extra/mason/server/notify/authors.txt b/extra/mason/server/notify/authors.txt deleted file mode 100644 index d4f5d6b3ae..0000000000 --- a/extra/mason/server/notify/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov \ No newline at end of file diff --git a/extra/mason/server/notify/notify.factor b/extra/mason/server/notify/notify.factor deleted file mode 100644 index bfa1027d92..0000000000 --- a/extra/mason/server/notify/notify.factor +++ /dev/null @@ -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>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 diff --git a/extra/mason/server/server.factor b/extra/mason/server/server.factor index 26be4df57c..d0fe29b917 100644 --- a/extra/mason/server/server.factor +++ b/extra/mason/server/server.factor @@ -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" ; diff --git a/extra/webapps/mason/download-package.xml b/extra/webapps/mason/download-package.xml index 43212cfc61..27102056f8 100644 --- a/extra/webapps/mason/download-package.xml +++ b/extra/webapps/mason/download-package.xml @@ -28,7 +28,7 @@ - + diff --git a/extra/webapps/mason/mason.factor b/extra/webapps/mason/mason.factor index ecb1348532..81eb36a17d 100644 --- a/extra/webapps/mason/mason.factor +++ b/extra/webapps/mason/mason.factor @@ -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 "make releases" >>description { can-make-releases? } >>capabilities + "make-release" add-responder - "make-release" add-responder ; + + "status-update" add-responder ; diff --git a/extra/webapps/mason/status-update/authors.txt b/extra/webapps/mason/status-update/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/webapps/mason/status-update/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/webapps/mason/status-update/status-update.factor b/extra/webapps/mason/status-update/status-update.factor new file mode 100644 index 0000000000..5156b1ef70 --- /dev/null +++ b/extra/webapps/mason/status-update/status-update.factor @@ -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 ; + +: ( -- 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" + ] if-secure + ] >>submit ;
Host name:
Last heartbeat:
Last heartbeat:
Current status:
Last build:
Last clean build: