From 8e98a238ff7861308927504a36b005301c11b899 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 4 Sep 2010 16:26:32 -0700 Subject: [PATCH] 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 | 26 +++++++---- extra/mason/mason.factor | 78 ++++++++++++++++++++++++++------ extra/mason/notify/notify.factor | 29 +++++++----- 3 files changed, 98 insertions(+), 35 deletions(-) diff --git a/extra/mason/email/email.factor b/extra/mason/email/email.factor index 1389a2e27c..4bdc8e7f6b 100644 --- a/extra/mason/email/email.factor +++ b/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 -prettyprint sequences io io.streams.string io.encodings.utf8 io.files -io.sockets mason.common mason.platform mason.config ; +USING: kernel namespaces accessors combinators make smtp +debugger prettyprint sequences io io.streams.string +io.encodings.utf8 io.files io.sockets fry continuations +mason.common mason.platform mason.config ; IN: mason.email : mason-email ( body content-type subject -- ) - - builder-from get >>from - builder-recipients get >>to - swap >>subject - swap >>content-type - swap >>body - send-email ; + '[ + + builder-from get >>from + builder-recipients get >>to + _ >>body + _ >>content-type + _ >>subject + send-email + ] [ + "E-MAILING FAILED:" print + error. flush + ] recover ; : subject-prefix ( -- string ) "mason on " platform ": " 3append ; diff --git a/extra/mason/mason.factor b/extra/mason/mason.factor index 3afa56290b..9ba0640ef7 100755 --- a/extra/mason/mason.factor +++ b/extra/mason/mason.factor @@ -1,31 +1,81 @@ ! 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 -mason.email mason.updates mason.notify namespaces threads ; +io.directories io.files kernel math math.order mason.common +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 -- ) - "FATAL BUILDER ERROR:" print - error. flush ; +: mb ( m -- n ) 1024 * 1024 * ; inline + +: 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 [ - notify-heartbeat - [ - builds/factor set-current-directory - new-code-available? [ build ] when - ] [ - build-loop-error - ] recover + builds/factor set-current-directory + check-disk-space + new-code-available? [ build ] when ] [ - build-loop-fatal + build-loop-error ] recover 5 minutes sleep build-loop ; diff --git a/extra/mason/notify/notify.factor b/extra/mason/notify/notify.factor index 144f0de122..b5580fe162 100644 --- a/extra/mason/notify/notify.factor +++ b/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 -- ) - [ - 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 - "arg" set - "report" set - ] H{ } make-assoc - [ 5 ] dip '[ _ status-url get http-post 2drop ] retry ; + '[ + 5 [ + [ + short-host-name "host-name" set + target-cpu get "target-cpu" set + target-os get "target-os" set + status-secret get "secret" set + _ "report" set + _ "arg" set + _ "message" set + ] H{ } make-assoc + status-url get http-post 2drop + ] retry + ] [ + "STATUS NOTIFY FAILED:" print + error. flush + ] recover ; : notify-heartbeat ( -- ) f f "heartbeat" status-notify ;