From ca4fc74b1fe1c213f56254af6eb128909c795ea3 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 12 Apr 2008 21:54:35 -0500 Subject: [PATCH] builder: more refactoring --- extra/builder/build/build.factor | 46 ++++ extra/builder/builder.factor | 250 +-------------------- extra/builder/child/child.factor | 70 ++++++ extra/builder/cleanup/cleanup.factor | 24 ++ extra/builder/common/common.factor | 49 +++- extra/builder/email/email.factor | 22 ++ extra/builder/release/branch/branch.factor | 2 +- extra/builder/release/release.factor | 7 +- extra/builder/report/report.factor | 35 +++ extra/builder/updates/updates.factor | 31 +++ extra/builder/util/util.factor | 23 +- 11 files changed, 303 insertions(+), 256 deletions(-) create mode 100644 extra/builder/build/build.factor create mode 100644 extra/builder/child/child.factor create mode 100644 extra/builder/cleanup/cleanup.factor create mode 100644 extra/builder/email/email.factor create mode 100644 extra/builder/report/report.factor create mode 100644 extra/builder/updates/updates.factor diff --git a/extra/builder/build/build.factor b/extra/builder/build/build.factor new file mode 100644 index 0000000000..e9f58980ea --- /dev/null +++ b/extra/builder/build/build.factor @@ -0,0 +1,46 @@ + +USING: io.files io.launcher io.encodings.utf8 prettyprint + builder.util builder.common builder.child builder.release + builder.report builder.email builder.cleanup ; + +IN: builder.build + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: create-build-dir ( -- ) + datestamp >stamp + build-dir make-directory ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: enter-build-dir ( -- ) build-dir set-current-directory ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: clone-builds-factor ( -- ) + { "git" "clone" builds/factor } to-strings try-process ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: record-id ( -- ) + "factor" + [ git-id "../git-id" utf8 [ . ] with-file-writer ] + with-directory ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: build ( -- ) + reset-status + create-build-dir + enter-build-dir + clone-builds-factor + record-id + build-child + release + report + email-report + cleanup ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +MAIN: build \ No newline at end of file diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index d81b934f2c..29daa8160b 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -1,259 +1,21 @@ -USING: kernel namespaces sequences splitting system combinators continuations - parser io io.files io.launcher io.sockets prettyprint threads - bootstrap.image benchmark vars bake smtp builder.util accessors - debugger io.encodings.utf8 - calendar - tools.test +USING: kernel debugger io.files threads calendar builder.common - builder.benchmark - builder.release ; + builder.updates + builder.build ; IN: builder ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: cd ( path -- ) set-current-directory ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: builds/factor ( -- path ) builds "factor" append-path ; -: build-dir ( -- path ) builds stamp> append-path ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: prepare-build-machine ( -- ) - builds make-directory - builds - [ - { "git" "clone" "git://factorcode.org/git/factor.git" } try-process - ] - with-directory ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: builds-check ( -- ) builds exists? not [ prepare-build-machine ] when ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: git-clone ( -- desc ) { "git" "clone" "../factor" } ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: enter-build-dir ( -- ) - datestamp >stamp - builds cd - stamp> make-directory - stamp> cd ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: git-id ( -- id ) - { "git" "show" } utf8 - [ readln ] with-stream " " split second ; - -: record-git-id ( -- ) git-id "../git-id" utf8 [ . ] with-file-writer ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: gnu-make ( -- string ) - os { freebsd openbsd netbsd } member? - [ "gmake" ] - [ "make" ] - if ; - -: do-make-clean ( -- ) { gnu-make "clean" } to-strings try-process ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: make-vm ( -- desc ) - - { gnu-make } to-strings >>command - "../compile-log" >>stdout - +stdout+ >>stderr ; - -: do-make-vm ( -- ) - make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: copy-image ( -- ) - builds/factor my-boot-image-name append-path ".." copy-file-into - builds/factor my-boot-image-name append-path "." copy-file-into ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: bootstrap-cmd ( -- cmd ) - { "./factor" { "-i=" my-boot-image-name } "-no-user-init" } to-strings ; - -: bootstrap ( -- desc ) - - bootstrap-cmd >>command - +closed+ >>stdin - "../boot-log" >>stdout - +stdout+ >>stderr - 60 minutes >>timeout ; - -: do-bootstrap ( -- ) - bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail ; - -: builder-test-cmd ( -- cmd ) - { "./factor" "-run=builder.test" } to-strings ; - -: builder-test ( -- desc ) - - builder-test-cmd >>command - +closed+ >>stdin - "../test-log" >>stdout - +stdout+ >>stderr - 240 minutes >>timeout ; - -: do-builder-test ( -- ) - builder-test [ "Test error" print "../test-log" 100 cat-n ] run-or-bail ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -SYMBOL: build-status - -: (build) ( -- ) - - builds-check - - build-status off - - enter-build-dir - - "report" utf8 - [ - "Build machine: " write host-name print - "CPU: " write cpu . - "OS: " write os . - "Build directory: " write current-directory get print - - git-clone [ "git clone failed" print ] run-or-bail - - "factor" - [ - record-git-id - do-make-clean - do-make-vm - copy-image - do-bootstrap - do-builder-test - ] - with-directory - - "test-log" delete-file - - "git id: " write "git-id" eval-file print nl - - "Boot time: " write "boot-time" eval-file milli-seconds>time print - "Load time: " write "load-time" eval-file milli-seconds>time print - "Test time: " write "test-time" eval-file milli-seconds>time print nl - - "Did not pass load-everything: " print "load-everything-vocabs" cat - - "Did not pass test-all: " print "test-all-vocabs" cat - "test-failures" cat - - "help-lint results:" print "help-lint" cat - - "Benchmarks: " print "benchmarks" eval-file benchmarks. - - nl - - show-benchmark-deltas - - "benchmarks" ".." copy-file-into - - release - ] - with-file-writer - - build-status on ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -SYMBOL: builder-from - -SYMBOL: builder-recipients - -: tag-subject ( str -- str ) { "builder@" host-name* ": " , } bake to-string ; - -: subject ( -- str ) build-status get [ "report" ] [ "error" ] if tag-subject ; - -: send-builder-email ( -- ) - - builder-from get >>from - builder-recipients get >>to - subject >>subject - "./report" file>string >>body - send-email ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: compress-image ( -- ) { "bzip2" my-boot-image-name } to-strings try-process ; - -! : build ( -- ) -! [ (build) ] try -! builds cd stamp> cd -! [ send-builder-email ] try -! { "rm" "-rf" "factor" } [ ] run-or-bail -! [ compress-image ] try ; - -: build ( -- ) - [ - (build) - build-dir - [ - { "rm" "-rf" "factor" } try-process - compress-image - ] - with-directory - ] - try - send-builder-email ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -USE: bootstrap.image.download - -: git-pull ( -- desc ) - { - "git" - "pull" - "--no-summary" - "git://factorcode.org/git/factor.git" - "master" - } ; - -: updates-available? ( -- ? ) - git-id - git-pull try-process - git-id - = not ; - -: new-image-available? ( -- ? ) - my-boot-image-name need-new-image? - [ download-my-image t ] - [ f ] - if ; - : build-loop ( -- ) builds-check [ - builds/factor - [ - updates-available? new-image-available? or - [ build ] - when - ] - with-directory + builds/factor set-current-directory + new-code-available? [ build ] when ] try 5 minutes sleep build-loop ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -MAIN: build-loop +MAIN: build-loop \ No newline at end of file diff --git a/extra/builder/child/child.factor b/extra/builder/child/child.factor new file mode 100644 index 0000000000..a63ae88f7f --- /dev/null +++ b/extra/builder/child/child.factor @@ -0,0 +1,70 @@ + +USING: namespaces debugger io.files io.launcher accessors bootstrap.image + calendar builder.util builder.common ; + +IN: builder.child + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: make-clean ( -- ) { gnu-make "clean" } to-strings try-process ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: make-vm ( -- ) + + gnu-make >>command + "../compile-log" >>stdout + +stdout+ >>stderr + try-process ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: builds-factor-image ( -- img ) builds/factor my-boot-image-name append-path ; + +: copy-image ( -- ) + builds-factor-image ".." copy-file-into + builds-factor-image "." copy-file-into ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: boot-cmd ( -- cmd ) + { "./factor" { "-i=" my-boot-image-name } "-no-user-init" } to-strings ; + +: boot ( -- ) + + boot-cmd >>command + +closed+ >>stdin + "../boot-log" >>stdout + +stdout+ >>stderr + 60 minutes >>timeout + try-process ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: test-cmd ( -- cmd ) { "./factor" "-run=builder.test" } ; + +: test ( -- ) + + test-cmd >>command + +closed+ >>stdin + "../test-log" >>stdout + +stdout+ >>stderr + 240 minutes >>timeout + try-process ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: (build-child) ( -- ) + make-clean + make-vm status-vm on + copy-image + boot status-boot on + test status-test on + status on ; + +! : build-child ( -- ) "factor" [ (build-child) ] with-directory ; + +: build-child ( -- ) + "factor" set-current-directory + [ (build-child) ] try + ".." set-current-directory ; diff --git a/extra/builder/cleanup/cleanup.factor b/extra/builder/cleanup/cleanup.factor new file mode 100644 index 0000000000..327b90e01f --- /dev/null +++ b/extra/builder/cleanup/cleanup.factor @@ -0,0 +1,24 @@ + +USING: kernel namespaces io.files io.launcher bootstrap.image + builder.util builder.common ; + +IN: builder.cleanup + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: builder-debug + +: compress-image ( -- ) { "bzip2" my-boot-image-name } to-strings try-process ; + +: delete-child-factor ( -- ) + build-dir [ { "rm" "-rf" "factor" } try-process ] with-directory ; + +: cleanup ( -- ) + builder-debug get f = + [ + "test-log" delete-file + delete-child-factor + compress-image + ] + when ; + diff --git a/extra/builder/common/common.factor b/extra/builder/common/common.factor index 2fe2aa06ab..e3c207eaaa 100644 --- a/extra/builder/common/common.factor +++ b/extra/builder/common/common.factor @@ -1,5 +1,7 @@ -USING: kernel namespaces io.files sequences vars ; +USING: kernel namespaces sequences splitting + io io.files io.launcher io.encodings.utf8 prettyprint + vars builder.util ; IN: builder.common @@ -16,4 +18,47 @@ SYMBOL: builds-dir VAR: stamp -SYMBOL: upload-to-factorcode \ No newline at end of file +: builds/factor ( -- path ) builds "factor" append-path ; +: build-dir ( -- path ) builds stamp> append-path ; + +: create-build-dir ( -- ) + datestamp >stamp + build-dir make-directory ; + +: enter-build-dir ( -- ) build-dir set-current-directory ; + +: clone-builds-factor ( -- ) + { "git" "clone" builds/factor } to-strings try-process ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: prepare-build-machine ( -- ) + builds make-directory + builds + [ { "git" "clone" "git://factorcode.org/git/factor.git" } try-process ] + with-directory ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: builds-check ( -- ) builds exists? not [ prepare-build-machine ] when ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: status-vm +SYMBOL: status-boot +SYMBOL: status-test +SYMBOL: status-build +SYMBOL: status-release +SYMBOL: status + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: reset-status ( -- ) + { status-vm status-boot status-test status-build status-release status } + [ off ] + each ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: upload-to-factorcode + diff --git a/extra/builder/email/email.factor b/extra/builder/email/email.factor new file mode 100644 index 0000000000..eed48cb177 --- /dev/null +++ b/extra/builder/email/email.factor @@ -0,0 +1,22 @@ + +USING: kernel namespaces accessors smtp builder.util builder.common ; + +IN: builder.email + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: builder-from +SYMBOL: builder-recipients + +: subject-status ( -- str ) status get [ "report" ] [ "error" ] if ; + +: subject ( -- str ) { "builder@" host-name* ": " subject-status } to-string ; + +: email-report ( -- ) + + builder-from get >>from + builder-recipients get >>to + subject >>subject + "report" file>string >>body + send-email ; + diff --git a/extra/builder/release/branch/branch.factor b/extra/builder/release/branch/branch.factor index 838a74394b..6218a2ea90 100644 --- a/extra/builder/release/branch/branch.factor +++ b/extra/builder/release/branch/branch.factor @@ -36,5 +36,5 @@ IN: builder.release.branch : update-clean-branch ( -- ) upload-to-factorcode get - [ update-clean-branch ] + [ (update-clean-branch) ] when ; diff --git a/extra/builder/release/release.factor b/extra/builder/release/release.factor index 33e5edfbf9..8f4c0e30f5 100644 --- a/extra/builder/release/release.factor +++ b/extra/builder/release/release.factor @@ -1,5 +1,5 @@ -USING: kernel system namespaces sequences splitting combinators +USING: kernel debugger system namespaces sequences splitting combinators io io.files io.launcher prettyprint bootstrap.image bake combinators.cleave builder.util @@ -18,9 +18,10 @@ IN: builder.release tidy make-archive upload - save-archive ; + save-archive + status-release on ; : clean-build? ( -- ? ) { "load-everything-vocabs" "test-all-vocabs" } [ eval-file empty? ] all? ; -: release ( -- ) clean-build? [ (release) ] when ; \ No newline at end of file +: release ( -- ) [ clean-build? [ (release) ] when ] try ; \ No newline at end of file diff --git a/extra/builder/report/report.factor b/extra/builder/report/report.factor new file mode 100644 index 0000000000..101d259f7c --- /dev/null +++ b/extra/builder/report/report.factor @@ -0,0 +1,35 @@ + +USING: kernel namespaces debugger system io io.files io.sockets + io.encodings.utf8 prettyprint benchmark + builder.util builder.common ; + +IN: builder.report + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: (report) ( -- ) + + "Build machine: " write host-name print + "CPU: " write cpu . + "OS: " write os . + "Build directory: " write build-dir print + "git id: " write "git-id" eval-file print nl + + status-vm get f = [ "compile-log" cat "vm compile error" throw ] when + status-boot get f = [ "boot-log" cat "Boot error" throw ] when + status-test get f = [ "test-log" 100 cat-n "Test error" throw ] when + + "Boot time: " write "boot-time" eval-file milli-seconds>time print + "Load time: " write "load-time" eval-file milli-seconds>time print + "Test time: " write "test-time" eval-file milli-seconds>time print nl + + "Did not pass load-everything: " print "load-everything-vocabs" cat + + "Did not pass test-all: " print "test-all-vocabs" cat + "test-failures" cat + + "help-lint results:" print "help-lint" cat + + "Benchmarks: " print "benchmarks" eval-file benchmarks. ; + +: report ( -- ) "report" utf8 [ [ (report) ] try ] with-file-writer ; \ No newline at end of file diff --git a/extra/builder/updates/updates.factor b/extra/builder/updates/updates.factor new file mode 100644 index 0000000000..a8184550e0 --- /dev/null +++ b/extra/builder/updates/updates.factor @@ -0,0 +1,31 @@ + +USING: kernel io.launcher bootstrap.image bootstrap.image.download + builder.util builder.common ; + +IN: builder.updates + +: git-pull-cmd ( -- cmd ) + { + "git" + "pull" + "--no-summary" + "git://factorcode.org/git/factor.git" + "master" + } ; + +: updates-available? ( -- ? ) + git-id + git-pull-cmd try-process + git-id + = not ; + +: new-image-available? ( -- ? ) + my-boot-image-name need-new-image? + [ download-my-image t ] + [ f ] + if ; + +: new-code-available? ( -- ? ) + updates-available? + new-image-available? + or ; \ No newline at end of file diff --git a/extra/builder/util/util.factor b/extra/builder/util/util.factor index e80d83e24c..3b0834b190 100644 --- a/extra/builder/util/util.factor +++ b/extra/builder/util/util.factor @@ -25,11 +25,11 @@ DEFER: to-strings : to-string ( obj -- str ) dup class { - { string [ ] } - { quotation [ call ] } - { word [ execute ] } - { fixnum [ number>string ] } - { array [ to-strings concat ] } + { \ string [ ] } + { \ quotation [ call ] } + { \ word [ execute ] } + { \ fixnum [ number>string ] } + { \ array [ to-strings concat ] } } case ; @@ -97,4 +97,15 @@ USE: prettyprint : cpu- ( -- cpu ) cpu unparse "." split "-" join ; -: platform ( -- string ) { [ os unparse ] cpu- } to-strings "-" join ; \ No newline at end of file +: platform ( -- string ) { [ os unparse ] cpu- } to-strings "-" join ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: gnu-make ( -- string ) + os { freebsd openbsd netbsd } member? [ "gmake" ] [ "make" ] if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: git-id ( -- id ) + { "git" "show" } utf8 [ readln ] with-stream + " " split second ;