From feffc260d6bec269906273fb4df04a05a998b63c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 5 Sep 2010 15:22:02 -0700 Subject: [PATCH] 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 --- extra/mason/build/build.factor | 11 +-- extra/mason/common/common-tests.factor | 7 -- extra/mason/common/common.factor | 14 ---- extra/mason/disk/authors.txt | 1 + extra/mason/disk/disk-tests.factor | 6 ++ extra/mason/disk/disk.factor | 27 +++++++ extra/mason/email/email.factor | 63 ++++++++++++--- extra/mason/git/authors.txt | 1 + extra/mason/git/git.factor | 102 +++++++++++++++++++++++++ extra/mason/mason.factor | 81 +++++--------------- extra/mason/report/report.factor | 10 ++- extra/mason/updates/updates.factor | 22 ++---- 12 files changed, 223 insertions(+), 122 deletions(-) create mode 100644 extra/mason/disk/authors.txt create mode 100644 extra/mason/disk/disk-tests.factor create mode 100644 extra/mason/disk/disk.factor create mode 100644 extra/mason/git/authors.txt create mode 100644 extra/mason/git/git.factor diff --git a/extra/mason/build/build.factor b/extra/mason/build/build.factor index 9a24be1f18..f556aae896 100644 --- a/extra/mason/build/build.factor +++ b/extra/mason/build/build.factor @@ -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 ( -- ) diff --git a/extra/mason/common/common-tests.factor b/extra/mason/common/common-tests.factor index b8e01d3993..1d1ea3d891 100644 --- a/extra/mason/common/common-tests.factor +++ b/extra/mason/common/common-tests.factor @@ -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 diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor index 05c0ac87bb..08b979e744 100644 --- a/extra/mason/common/common.factor +++ b/extra/mason/common/common.factor @@ -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" diff --git a/extra/mason/disk/authors.txt b/extra/mason/disk/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/mason/disk/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/mason/disk/disk-tests.factor b/extra/mason/disk/disk-tests.factor new file mode 100644 index 0000000000..b1c0a7e28f --- /dev/null +++ b/extra/mason/disk/disk-tests.factor @@ -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 diff --git a/extra/mason/disk/disk.factor b/extra/mason/disk/disk.factor new file mode 100644 index 0000000000..ca4a703aaf --- /dev/null +++ b/extra/mason/disk/disk.factor @@ -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 ; diff --git a/extra/mason/email/email.factor b/extra/mason/email/email.factor index 4bdc8e7f6b..68724b3ffa 100644 --- a/extra/mason/email/email.factor +++ b/extra/mason/email/email.factor @@ -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 ; diff --git a/extra/mason/git/authors.txt b/extra/mason/git/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/mason/git/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/mason/git/git.factor b/extra/mason/git/git.factor new file mode 100644 index 0000000000..df344be12e --- /dev/null +++ b/extra/mason/git/git.factor @@ -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 ; + +> "not uptodate. Cannot merge." swap start + [ git-repo-corrupted ] + [ rethrow ] + if + ] [ rethrow ] if ; + +: with-process-reader* ( desc encoding quot -- ) + [ ] 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 ; diff --git a/extra/mason/mason.factor b/extra/mason/mason.factor index 565129ae82..7d20ee0d4d 100755 --- a/extra/mason/mason.factor +++ b/extra/mason/mason.factor @@ -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 \ No newline at end of file diff --git a/extra/mason/report/report.factor b/extra/mason/report/report.factor index c5567c9c97..926207be00 100644 --- a/extra/mason/report/report.factor +++ b/extra/mason/report/report.factor @@ -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

Build report for <->/<->

+
Build machine:<->
Disk usage:<->
Build directory:<->
GIT ID:<->
diff --git a/extra/mason/updates/updates.factor b/extra/mason/updates/updates.factor index 2d1ebe1175..016c1a6d79 100644 --- a/extra/mason/updates/updates.factor +++ b/extra/mason/updates/updates.factor @@ -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 + #! Must be run from builds-dir + git-pull latest-boot-image latest-counter latest-sources set-global ; : build? ( -- ? )