mason: check free disk space, and don't send too many e-mails within a short period if the local git repo becomes corrupted, etc

extra/mason/email/email.factor

@@ -1,18 +1,24 @@
 ! Copyright (C) 2008, 2010 Eduardo Cavazos, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces accessors combinators make smtp debugger
+USING: kernel namespaces accessors combinators make smtp
-prettyprint sequences io io.streams.string io.encodings.utf8 io.files
+debugger prettyprint sequences io io.streams.string
-io.sockets mason.common mason.platform mason.config ;
+io.encodings.utf8 io.files io.sockets fry continuations
+mason.common mason.platform mason.config ;
 IN: mason.email
 
 : mason-email ( body content-type subject -- )
+    '[
         <email>
             builder-from get >>from
             builder-recipients get >>to
-        swap >>subject
+            _ >>body
-        swap >>content-type
+            _ >>content-type
-        swap >>body
+            _ >>subject
-    send-email ;
+        send-email
+    ] [
+        "E-MAILING FAILED:" print
+        error. flush
+    ] recover ;
 
 : subject-prefix ( -- string )
     "mason on " platform ": " 3append ;

extra/mason/mason.factor

@@ -1,32 +1,82 @@
 ! Copyright (C) 2008, 2010 Eduardo Cavazos, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors calendar continuations debugger io
-io.directories io.files kernel mason.common
+io.directories io.files kernel math math.order mason.common
-mason.email mason.updates mason.notify namespaces threads ;
+mason.email mason.updates mason.notify namespaces threads
+combinators io.pathnames io.files.info ;
 FROM: mason.build => build ;
 IN: mason
 
+SYMBOL: last-email-time
+
+SYMBOL: next-email-time
+
+: send-email-throttled? ( -- ? )
+    ! We sent too many errors. See if its time to send a new
+    ! one again.
+    now next-email-time get-global after?
+    [ f next-email-time set-global t ] [ f ] if ;
+
+: throttle-time ( -- dt ) 6 hours ;
+
+: throttle-emails ( -- )
+    ! Last e-mail was less than 20 minutes ago. Don't send any
+    ! errors for 4 hours.
+    throttle-time hence next-email-time set-global
+    f last-email-time set-global ;
+
+: maximum-frequency ( -- dt ) 30 minutes ;
+
+: send-email-capped? ( -- ? )
+    ! We're about to send an error after sending another one.
+    ! See if we should start throttling emails.
+    last-email-time get-global
+    maximum-frequency ago
+    after?
+    [ throttle-emails f ] [ t ] if ;
+
+: send-email? ( -- ? )
+    {
+        { [ next-email-time get-global ] [ send-email-throttled? ] }
+        { [ last-email-time get-global ] [ send-email-capped? ] }
+        [ now last-email-time set-global t ]
+    } cond
+    dup [ now last-email-time set-global ] when ;
+
+: email-fatal-error ( error -- )
+    send-email? [
+        now last-email-time set-global
+        error-continuation get call>> email-error
+    ] [ drop ] if ;
+
 : build-loop-error ( error -- )
     [ "Build loop error:" print flush error. flush :c flush ]
-    [ error-continuation get call>> email-error ] bi ;
+    [ email-fatal-error ]
+    bi ;
 
-: build-loop-fatal ( error -- )
+: mb ( m -- n ) 1024 * 1024 * ; inline
-    "FATAL BUILDER ERROR:" print
+
-    error. flush ;
+: sufficient-disk-space? ( -- ? )
+    ! We want at least 300Mb to be available before starting
+    ! a build.
+    current-directory get file-system-info available-space>>
+    300 mb > ;
+
+: check-disk-space ( -- )
+    sufficient-disk-space? [
+        "Less than 300 Mb free disk space." throw
+    ] unless ;
 
 : build-loop ( -- )
     ?prepare-build-machine
-    [
     notify-heartbeat
     [
         builds/factor set-current-directory
+        check-disk-space
         new-code-available? [ build ] when
     ] [
         build-loop-error
     ] recover
-    ] [
-        build-loop-fatal
-    ] recover
     5 minutes sleep
     build-loop ;
 

extra/mason/notify/notify.factor

@@ -2,20 +2,27 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors fry http.client io io.encodings.utf8 io.files
 kernel mason.common mason.config mason.email mason.twitter
-namespaces prettyprint sequences ;
+namespaces prettyprint sequences debugger continuations ;
 IN: mason.notify
 
 : status-notify ( report arg message -- )
+    '[
+        5 [
             [
                 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
+                _ "report" set
-        "arg" set
+                _ "arg" set
-        "report" set
+                _ "message" set
             ] H{ } make-assoc
-    [ 5 ] dip '[ _ status-url get http-post 2drop ] retry ;
+            status-url get http-post 2drop
+        ] retry
+    ] [
+        "STATUS NOTIFY FAILED:" print
+        error. flush
+    ] recover ;
 
 : notify-heartbeat ( -- )
     f f "heartbeat" status-notify ;