! 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
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 ( -- )
[ "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
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"
--- /dev/null
+Slava Pestov
--- /dev/null
+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
--- /dev/null
+! 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 ;
! 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 -- )
: 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 ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! 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 ;
! 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
-
-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 > ;
+: fatal-error-body ( error callstack -- string )
+ [
+ "Fatal error on " write host-name print nl
+ [ error. ] [ callstack. ] bi*
+ ] with-string-writer ;
-: 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
-! 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 )
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>
! 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 ;
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 ;
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? ( -- ? )
projects / factor.git / commitdiff