extra/mason/notify/server/server.factor

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors combinators combinators.smart command-line db
   4 db.sqlite db.tuples db.types io io.encodings.utf8 io.files
   5 present kernel namespaces sequences calendar ;
   6 IN: mason.notify.server
   7
   8 CONSTANT: +starting+ "starting"
   9 CONSTANT: +make-vm+ "make-vm"
  10 CONSTANT: +boot+ "boot"
  11 CONSTANT: +test+ "test"
  12 CONSTANT: +clean+ "status-clean"
  13 CONSTANT: +dirty+ "status-dirty"
  14 CONSTANT: +error+ "status-error"
  15
  16 TUPLE: builder
  17 host-name os cpu
  18 clean-git-id clean-timestamp
  19 last-release release-git-id
  20 last-git-id last-timestamp last-report
  21 current-git-id current-timestamp
  22 status ;
  23
  24 builder "BUILDERS" {
  25     { "host-name" "HOST_NAME" TEXT +user-assigned-id+ }
  26     { "os" "OS" TEXT +user-assigned-id+ }
  27     { "cpu" "CPU" TEXT +user-assigned-id+ }
  28
  29     { "clean-git-id" "CLEAN_GIT_ID" TEXT }
  30     { "clean-timestamp" "CLEAN_TIMESTAMP" TIMESTAMP }
  31
  32     { "last-release" "LAST_RELEASE" TEXT }
  33     { "release-git-id" "RELEASE_GIT_ID" TEXT }
  34
  35     { "last-git-id" "LAST_GIT_ID" TEXT }
  36     { "last-timestamp" "LAST_TIMESTAMP" TIMESTAMP }
  37     { "last-report" "LAST_REPORT" TEXT }
  38
  39     { "current-git-id" "CURRENT_GIT_ID" TEXT }
  40     ! Can't name it CURRENT_TIMESTAMP because of bug in db library
  41     { "current-timestamp" "CURR_TIMESTAMP" TIMESTAMP }
  42     { "status" "STATUS" TEXT }
  43 } define-persistent
  44
  45 SYMBOLS: host-name target-os target-cpu message message-arg ;
  46
  47 : parse-args ( command-line -- )
  48     dup last message-arg set
  49     [
  50         {
  51             [ host-name set ]
  52             [ target-cpu set ]
  53             [ target-os set ]
  54             [ message set ]
  55         } spread
  56     ] input<sequence ;
  57
  58 : find-builder ( -- builder )
  59     builder new
  60         host-name get >>host-name
  61         target-os get >>os
  62         target-cpu get >>cpu
  63     dup select-tuple [ ] [ dup insert-tuple ] ?if ;
  64
  65 : git-id ( builder id -- )
  66     >>current-git-id +starting+ >>status drop ;
  67
  68 : make-vm ( builder -- ) +make-vm+ >>status drop ;
  69
  70 : boot ( builder -- ) +boot+ >>status drop ;
  71
  72 : test ( builder -- ) +test+ >>status drop ;
  73
  74 : report ( builder status content -- )
  75     [ >>status ] [ >>last-report ] bi*
  76     dup status>> +clean+ = [
  77         dup current-git-id>> >>clean-git-id
  78         dup current-timestamp>> >>clean-timestamp
  79     ] when
  80     dup current-git-id>> >>last-git-id
  81     dup current-timestamp>> >>last-timestamp
  82     drop ;
  83
  84 : release ( builder name -- )
  85     >>last-release
  86     dup clean-git-id>> >>release-git-id
  87     drop ;
  88
  89 : update-builder ( builder -- )
  90     message get {
  91         { "git-id" [ message-arg get git-id ] }
  92         { "make-vm" [ make-vm ] }
  93         { "boot" [ boot ] }
  94         { "test" [ test ] }
  95         { "report" [ message-arg get contents report ] }
  96         { "release" [ message-arg get release ] }
  97     } case ;
  98
  99 : mason-db ( -- db ) "resource:mason.db" <sqlite-db> ;
 100
 101 : handle-update ( command-line timestamp -- )
 102     mason-db [
 103         [ parse-args find-builder ] dip >>current-timestamp
 104         [ update-builder ] [ update-tuple ] bi
 105     ] with-db ;
 106
 107 CONSTANT: log-file "resource:mason.log"
 108
 109 : log-update ( command-line timestamp -- )
 110     log-file utf8 [
 111         present write ": " write " " join print
 112     ] with-file-appender ;
 113
 114 : main ( -- )
 115     command-line get now [ log-update ] [ handle-update ] 2bi ;
 116
 117 MAIN: main