118 lines
3.2 KiB
Factor
118 lines
3.2 KiB
Factor
! 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 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+ "status-clean"
|
|
CONSTANT: +dirty+ "status-dirty"
|
|
CONSTANT: +error+ "status-error"
|
|
|
|
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
|
|
|
|
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 ;
|
|
|
|
: 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 {
|
|
{ "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 ;
|
|
|
|
: mason-db ( -- db ) "resource:mason.db" <sqlite-db> ;
|
|
|
|
: handle-update ( command-line timestamp -- )
|
|
mason-db [
|
|
[ 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 now [ log-update ] [ handle-update ] 2bi ;
|
|
|
|
MAIN: main
|