mason: various assorted improvements

- put disk usage in build report
- bump minimum disk space required before starting a build from 300mb to 1gb
- check repository consistency before pulling; if there are untracked files, or if the pull fails, blow away the repo and clone it again
db4
Slava Pestov 2010-09-05 15:22:02 -07:00
parent 3c4cf722f4
commit feffc260d6
12 changed files with 223 additions and 122 deletions

View File

@ -2,9 +2,9 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel calendar io.directories io.encodings.utf8
io.files io.launcher io.pathnames namespaces prettyprint
combinators mason.child mason.cleanup mason.common mason.help
mason.release mason.report mason.email mason.notify
mason.platform mason.updates ;
combinators mason.child mason.cleanup mason.common mason.config
mason.help mason.release mason.report mason.email mason.git
mason.notify mason.platform mason.updates ;
QUALIFIED: continuations
IN: mason.build
@ -16,10 +16,11 @@ IN: mason.build
build-dir set-current-directory ;
: clone-source ( -- )
"git" "clone" builds/factor 3array short-running-process ;
"git" "clone" builds-dir get "factor" append-path 3array
short-running-process ;
: copy-image ( -- )
builds/factor boot-image-name append-path
builds-dir get boot-image-name append-path
[ "." copy-file-into ] [ "factor" copy-file-into ] bi ;
: save-git-id ( -- )

View File

@ -5,13 +5,6 @@ io.files.temp io.encodings.utf8 sequences ;
[ "00:01:02" ] [ 62,000,000,000 nanos>time ] unit-test
[ "/home/bobby/builds/factor" ] [
[
"/home/bobby/builds" builds-dir set
builds/factor
] with-scope
] unit-test
[ t ] [
[
"/home/bobby/builds" builds-dir set

View File

@ -68,22 +68,8 @@ M: unix (really-delete-tree) delete-tree ;
SYMBOL: stamp
: builds/factor ( -- path ) builds-dir get "factor" append-path ;
: build-dir ( -- path ) builds-dir get stamp get append-path ;
: prepare-build-machine ( -- )
builds-dir get make-directories
builds-dir get
[ { "git" "clone" "git://factorcode.org/git/factor.git" } try-output-process ]
with-directory ;
: git-id ( -- id )
{ "git" "show" } utf8 [ lines ] with-process-reader
first " " split second ;
: ?prepare-build-machine ( -- )
builds/factor exists? [ prepare-build-machine ] unless ;
CONSTANT: load-all-vocabs-file "load-everything-vocabs"
CONSTANT: load-all-errors-file "load-everything-errors"

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -0,0 +1,6 @@
USING: mason.disk tools.test strings sequences ;
IN: mason.disk.tests
[ t ] [ disk-usage string? ] unit-test
[ t ] [ sufficient-disk-space? { t f } member? ] unit-test

View File

@ -0,0 +1,27 @@
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors io.files.info io.pathnames kernel math
math.parser namespaces sequences mason.config ;
IN: mason.disk
: gb ( -- n ) 30 2^ ; inline
: sufficient-disk-space? ( -- ? )
! We want at least 300Mb to be available before starting
! a build.
current-directory get file-system-info available-space>>
gb > ;
: check-disk-space ( -- )
sufficient-disk-space? [
"Less than 1 Gb free disk space." throw
] unless ;
: mb-str ( n -- string ) gb /i number>string ;
: disk-usage ( -- string )
builds-dir get file-system-info
[ used-space>> ] [ total-space>> ] bi
[ [ mb-str ] bi@ " / " glue " Gb used" append ]
[ [ 100 * ] dip /i number>string "(" "%)" surround ] 2bi
" " glue ;

View File

@ -1,9 +1,9 @@
! 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 fry continuations
mason.common mason.platform mason.config ;
USING: accessors calendar combinators continuations debugger fry
io io.encodings.utf8 io.files io.sockets kernel make
mason.common mason.config mason.platform math.order namespaces
prettyprint sequences smtp ;
IN: mason.email
: mason-email ( body content-type subject -- )
@ -38,11 +38,52 @@ IN: mason.email
: email-report ( report status -- )
[ "text/html" ] dip report-subject mason-email ;
: email-error ( error callstack -- )
! Some special logic to throttle the amount of fatal errors
! coming in, if eg git-daemon goes down on factorcode.org and
! it fails pulling every 5 minutes.
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 ;
: email-fatal? ( -- ? )
{
{ [ 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 ( string subject -- )
[ print nl print flush ]
[
"Fatal error on " write host-name print nl
[ error. ] [ callstack. ] bi*
] with-string-writer
"text/plain"
subject-prefix "fatal error" append
mason-email ;
email-fatal? [
now last-email-time set-global
[ "text/plain" subject-prefix ] dip append
mason-email
] [ 2drop ] if
] 2bi ;

View File

@ -0,0 +1 @@
Slava Pestov

102
extra/mason/git/git.factor Normal file
View File

@ -0,0 +1,102 @@
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators.short-circuit continuations
debugger io io.directories io.encodings.utf8 io.files
io.launcher io.sockets io.streams.string kernel mason.common
mason.email sequences splitting ;
IN: mason.git
: git-id ( -- id )
{ "git" "show" } utf8 [ lines ] with-process-reader
first " " split second ;
<PRIVATE
: git-clone-cmd ( -- cmd )
{
"git"
"clone"
"git://factorcode.org/git/factor.git"
} ;
: git-clone ( -- )
#! Must be run from builds-dir
git-clone-cmd try-output-process ;
: git-pull-cmd ( -- cmd )
{
"git"
"pull"
"git://factorcode.org/git/factor.git"
"master"
} ;
: repo-corrupted-body ( error -- string )
[
"Corrupted repository on " write host-name write " will be re-cloned." print
"Error while pulling was:" print
nl
error.
] with-string-writer ;
: git-repo-corrupted ( error -- )
repo-corrupted-body "corrupted repo" email-fatal
"factor" really-delete-tree
git-clone ;
: git-pull-failed ( error -- )
dup output-process-error? [
dup output>> "not uptodate. Cannot merge." swap start
[ git-repo-corrupted ]
[ rethrow ]
if
] [ rethrow ] if ;
: with-process-reader* ( desc encoding quot -- )
[ <process-reader*> ] dip swap [ with-input-stream ] dip
dup wait-for-process dup { 0 1 } member?
[ 2drop ] [ process-failed ] if ; inline
: git-status-cmd ( -- cmd )
{ "git" "status" } ;
: git-status-failed ( error -- )
#! Exit code 1 means there's nothing to commit.
dup { [ process-failed? ] [ code>> 1 = ] } 1&&
[ drop ] [ rethrow ] if ;
: git-status ( -- seq )
[
git-status-cmd utf8 [ lines ] with-process-reader*
[ "#\t" head? ] filter
] [ git-status-failed { } ] recover ;
: check-repository ( -- seq )
"factor" [ git-status ] with-directory ;
: repo-dirty-body ( error -- string )
[
"Dirty repository on " write host-name write " will be re-cloned." print
"Modified and untracked files:" print nl
[ print ] each
] with-string-writer ;
: git-repo-dirty ( files -- )
repo-dirty-body "dirty repo" email-fatal
"factor" really-delete-tree
git-clone ;
PRIVATE>
: git-pull ( -- id )
#! Must be run from builds-dir.
"factor" exists? [
check-repository [
"factor" [
[ git-pull-cmd short-running-process ]
[ git-pull-failed ]
recover
] with-directory
] [ git-repo-dirty ] if-empty
] [ git-clone ] if
"factor" [ git-id ] with-directory ;

View File

@ -1,85 +1,38 @@
! 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 math math.order mason.common
mason.email mason.updates mason.notify namespaces threads
combinators io.pathnames io.files.info ;
io.directories io.pathnames io.sockets io.streams.string kernel
mason.config mason.disk mason.email mason.notify mason.updates
namespaces prettyprint threads ;
FROM: mason.build => build ;
IN: mason
SYMBOL: last-email-time
: fatal-error-body ( error callstack -- string )
[
"Fatal error on " write host-name print nl
[ error. ] [ callstack. ] bi*
] with-string-writer ;
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 ]
[ email-fatal-error ]
bi ;
: 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-error ( error callstack -- )
fatal-error-body
"build loop error"
email-fatal ;
: build-loop ( -- )
?prepare-build-machine
notify-heartbeat
[
builds/factor [
builds-dir get make-directories
builds-dir get [
check-disk-space
update-sources
build? [ build ] [ 5 minutes sleep ] if
] with-directory
] [
build-loop-error
error-continuation get call>> build-loop-error
5 minutes sleep
] recover
build-loop ;
MAIN: build-loop

View File

@ -1,10 +1,10 @@
! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
! Copyright (C) 2008, 2010 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: benchmark combinators.smart debugger fry io assocs
io.encodings.utf8 io.files io.sockets io.streams.string kernel
locals mason.common mason.config mason.platform math namespaces
prettyprint sequences xml.syntax xml.writer combinators.short-circuit
literals splitting ;
locals mason.common mason.config mason.disk mason.platform math
namespaces prettyprint sequences xml.syntax xml.writer
combinators.short-circuit literals splitting ;
IN: mason.report
: git-link ( id -- link )
@ -15,12 +15,14 @@ IN: mason.report
target-os get
target-cpu get
short-host-name
disk-usage
build-dir
current-git-id get git-link
[XML
<h1>Build report for <->/<-></h1>
<table>
<tr><td>Build machine:</td><td><-></td></tr>
<tr><td>Disk usage:</td><td><-></td></tr>
<tr><td>Build directory:</td><td><-></td></tr>
<tr><td>GIT ID:</td><td><-></td></tr>
</table>

View File

@ -1,8 +1,8 @@
! Copyright (C) 2008, 2010 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.download http.client init io.directories
io.launcher kernel math.parser namespaces mason.config
mason.common mason.platform ;
USING: bootstrap.image.download http.client init kernel
math.parser namespaces mason.config mason.common mason.git
mason.platform ;
IN: mason.updates
TUPLE: sources git-id boot-image counter ;
@ -16,19 +16,6 @@ SYMBOLS: latest-sources last-built-sources ;
f last-built-sources set-global
] "mason.updates" add-startup-hook
: git-pull-cmd ( -- cmd )
{
"git"
"pull"
"--no-summary"
"git://factorcode.org/git/factor.git"
"master"
} ;
: latest-git-id ( -- git-id )
git-pull-cmd short-running-process
git-id ;
: latest-boot-image ( -- boot-image )
boot-image-name
[ maybe-download-image drop ] [ file-checksum ] bi ;
@ -37,7 +24,8 @@ SYMBOLS: latest-sources last-built-sources ;
counter-url get-global http-get nip string>number ;
: update-sources ( -- )
latest-git-id latest-boot-image latest-counter <sources>
#! Must be run from builds-dir
git-pull latest-boot-image latest-counter <sources>
latest-sources set-global ;
: build? ( -- ? )