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
Slava Pestov
parent
aa2f5ae13f
commit
8e98a238ff
|
|
@ -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 -- )
|
||||
<email>
|
||||
builder-from get >>from
|
||||
builder-recipients get >>to
|
||||
swap >>subject
|
||||
swap >>content-type
|
||||
swap >>body
|
||||
send-email ;
|
||||
'[
|
||||
<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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue