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

@@ -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
+combinators mason.child mason.cleanup mason.common mason.config
-mason.release mason.report mason.email mason.notify
+mason.help mason.release mason.report mason.email mason.git
-mason.platform mason.updates ;
+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 ( -- )

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

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"
 

extra/mason/disk/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

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

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 ;

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
+USING: accessors calendar combinators continuations debugger fry
-debugger prettyprint sequences io io.streams.string
+io io.encodings.utf8 io.files io.sockets kernel make
-io.encodings.utf8 io.files io.sockets fry continuations
+mason.common mason.config mason.platform math.order namespaces
-mason.common mason.platform mason.config ;
+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
+        email-fatal? [
-        [ error. ] [ callstack. ] bi*
+            now last-email-time set-global
-    ] with-string-writer
+            [ "text/plain" subject-prefix ] dip append
-    "text/plain"
+            mason-email
-    subject-prefix "fatal error" append
+        ] [ 2drop ] if
-    mason-email ;
+    ] 2bi ;

extra/mason/git/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

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 ;
+
+<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 ;

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
+io.directories io.pathnames io.sockets io.streams.string kernel
-mason.email mason.updates mason.notify namespaces threads
+mason.config mason.disk mason.email mason.notify mason.updates
-combinators io.pathnames io.files.info ;
+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
+: build-loop-error ( error callstack -- )
-
+    fatal-error-body
-: send-email-throttled? ( -- ? )
+     "build loop error"
-    ! We sent too many errors. See if its time to send a new
+     email-fatal ;
-    ! 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 ( -- )
-    ?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

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
+locals mason.common mason.config mason.disk mason.platform math
-prettyprint sequences xml.syntax xml.writer combinators.short-circuit
+namespaces prettyprint sequences xml.syntax xml.writer
-literals splitting ;
+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>

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
+USING: bootstrap.image.download http.client init kernel
-io.launcher kernel math.parser namespaces mason.config
+math.parser namespaces mason.config mason.common mason.git
-mason.common mason.platform ;
+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? ( -- ? )