mason: use web service instead of shell script for status notifications, to scale better in the cloud

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.
+! URL for status notifications.
-SYMBOL: status-host
+SYMBOL: status-url
 
-! Username to log in.
+! Password for status notifications.
-SYMBOL: status-username
+SYMBOL: status-secret
 
 SYMBOL: upload-help?
 

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
+USING: accessors fry http.client io io.encodings.utf8 io.files
-io.launcher kernel make mason.config mason.common mason.email
+kernel mason.common mason.config mason.email mason.twitter
-mason.twitter namespaces sequences prettyprint fry ;
+namespaces prettyprint sequences ;
 IN: mason.notify
 
-: status-notify ( input-file args -- )
+: status-notify ( report arg message -- )
-    status-host get [
     [
-            "ssh" , status-host get , "-l" , status-username get ,
+        short-host-name "host-name" set
-            "./mason-notify" ,
+        target-cpu get "target-cpu" set
-            short-host-name ,
+        target-os get "target-os" set
-            target-cpu get ,
+        status-secret get "secret" set
-            target-os get ,
+        "message" set
-        ] { } make prepend
+        "arg" set
-        [ 5 ] 2dip '[
+        "report" set
-            <process>
+    ] H{ } make-assoc
-                _ >>stdin
+    [ 5 ] dip '[ _ status-url get http-post 2drop ] retry ;
-                _ >>command
-            short-running-process
-        ] retry
-    ] [ 2drop ] if ;
 
 : 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
+        [ "report" utf8 file-contents ] dip
-        [ [ utf8 file-contents ] dip email-report ]
+        [ name>> "report" status-notify ] [ email-report ] 2bi
-        [ "report" swap name>> 2array status-notify ]
-        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 ;

extra/mason/server/notify/authors.txt

@@ -1 +0,0 @@
-Slava Pestov

extra/mason/server/notify/notify.factor

@@ -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<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

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
+status ;
-heartbeat-timestamp ;
 
 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" <sqlite-db> ;

extra/webapps/mason/download-package.xml

@@ -28,7 +28,7 @@
 
     <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>

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
         <protected>
             "make releases" >>description
             { can-make-releases? } >>capabilities
+        "make-release" add-responder
 
-        "make-release" add-responder ;
+    <status-update-action>
+        "status-update" add-responder ;

extra/webapps/mason/status-update/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

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 ;
+
+: <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 ;