extra/webapps/mason/status-update/status-update.factor

   1 ! Copyright (C) 2010 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors calendar combinators db.tuples furnace.actions
   4 furnace.redirection html.forms http.server.responses io kernel
   5 namespaces validators webapps.mason.utils webapps.mason.backend ;
   6 IN: webapps.mason.status-update
   7
   8 : find-builder ( host-name os cpu -- builder )
   9     builder new
  10         swap >>cpu
  11         swap >>os
  12         swap >>host-name
  13     dup select-tuple [ ] [ dup insert-tuple ] ?if ;
  14
  15 : heartbeat ( builder -- )
  16     now >>heartbeat-timestamp
  17     drop ;
  18
  19 : status ( builder status -- )
  20     >>status
  21     now >>current-timestamp
  22     drop ;
  23
  24 : idle ( builder -- ) +idle+ status ;
  25
  26 : git-id ( builder id -- ) >>current-git-id +starting+ status ;
  27
  28 : make-vm ( builder -- ) +make-vm+ status ;
  29
  30 : boot ( builder -- ) +boot+ status ;
  31
  32 : test ( builder -- ) +test+ status ;
  33
  34 : report ( builder content status -- )
  35     [
  36         >>last-report
  37         now >>current-timestamp
  38     ] dip
  39     +clean+ = [
  40         dup current-git-id>> >>clean-git-id
  41         dup current-timestamp>> >>clean-timestamp
  42     ] when
  43     dup current-git-id>> >>last-git-id
  44     dup current-timestamp>> >>last-timestamp
  45     drop ;
  46
  47 : upload ( builder -- ) +upload+ status ;
  48
  49 : finish ( builder -- ) +finish+ status ;
  50
  51 : release ( builder name -- )
  52     >>last-release
  53     dup clean-git-id>> >>release-git-id
  54     drop ;
  55
  56 : update-builder ( builder -- )
  57     "message" value {
  58         { "heartbeat" [ heartbeat ] }
  59         { "idle" [ idle ] }
  60         { "git-id" [ "arg" value git-id ] }
  61         { "make-vm" [ make-vm ] }
  62         { "boot" [ boot ] }
  63         { "test" [ test ] }
  64         { "report" [ "report" value "arg" value report ] }
  65         { "upload" [ upload ] }
  66         { "finish" [ finish ] }
  67         { "release" [ "arg" value release ] }
  68     } case ;
  69
  70 : <status-update-action> ( -- action )
  71     <action>
  72     [
  73         {
  74             { "host-name" [ v-one-line ] }
  75             { "target-cpu" [ v-one-line ] }
  76             { "target-os" [ v-one-line ] }
  77             { "message" [ v-one-line ] }
  78             { "arg" [ [ v-one-line ] v-optional ] }
  79             { "report" [ ] }
  80         } validate-params
  81
  82         validate-secret
  83     ] >>validate
  84
  85     [
  86         [
  87             "host-name" value
  88             "target-os" value
  89             "target-cpu" value
  90             find-builder
  91             [ update-builder ] [ update-tuple ] bi
  92         ] with-mason-db
  93         "OK" <text-content>
  94     ] >>submit ;