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 againdb4
Slava Pestov
parent
3c4cf722f4
commit
feffc260d6
|
|
@ -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 ( -- )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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
|
||||
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -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? ( -- ? )
|
||||
|
|
|
|||
Loading…
Reference in New Issue