+++ /dev/null
-Slava Pestov
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators combinators.smart command-line db
-db.sqlite db.tuples db.types io io.encodings.utf8 io.files
-present kernel namespaces sequences calendar ;
-IN: mason.notify.server
-
-CONSTANT: +starting+ "starting"
-CONSTANT: +make-vm+ "make-vm"
-CONSTANT: +boot+ "boot"
-CONSTANT: +test+ "test"
-CONSTANT: +clean+ "status-clean"
-CONSTANT: +dirty+ "status-dirty"
-CONSTANT: +error+ "status-error"
-
-TUPLE: builder
-host-name os cpu
-clean-git-id clean-timestamp
-last-release release-git-id
-last-git-id last-timestamp last-report
-current-git-id current-timestamp
-status ;
-
-builder "BUILDERS" {
- { "host-name" "HOST_NAME" TEXT +user-assigned-id+ }
- { "os" "OS" TEXT +user-assigned-id+ }
- { "cpu" "CPU" TEXT +user-assigned-id+ }
-
- { "clean-git-id" "CLEAN_GIT_ID" TEXT }
- { "clean-timestamp" "CLEAN_TIMESTAMP" TIMESTAMP }
-
- { "last-release" "LAST_RELEASE" TEXT }
- { "release-git-id" "RELEASE_GIT_ID" TEXT }
-
- { "last-git-id" "LAST_GIT_ID" TEXT }
- { "last-timestamp" "LAST_TIMESTAMP" TIMESTAMP }
- { "last-report" "LAST_REPORT" TEXT }
-
- { "current-git-id" "CURRENT_GIT_ID" TEXT }
- ! Can't name it CURRENT_TIMESTAMP because of bug in db library
- { "current-timestamp" "CURR_TIMESTAMP" TIMESTAMP }
- { "status" "STATUS" TEXT }
-} define-persistent
-
-SYMBOLS: host-name target-os target-cpu message message-arg ;
-
-: parse-args ( command-line -- )
- dup last message-arg set
- [
- {
- [ host-name set ]
- [ target-cpu set ]
- [ target-os set ]
- [ message set ]
- } spread
- ] input<sequence ;
-
-: find-builder ( -- builder )
- builder new
- host-name get >>host-name
- target-os get >>os
- target-cpu get >>cpu
- dup select-tuple [ ] [ dup insert-tuple ] ?if ;
-
-: git-id ( builder id -- )
- >>current-git-id +starting+ >>status drop ;
-
-: make-vm ( builder -- ) +make-vm+ >>status drop ;
-
-: boot ( builder -- ) +boot+ >>status drop ;
-
-: test ( builder -- ) +test+ >>status drop ;
-
-: report ( builder status content -- )
- [ >>status ] [ >>last-report ] bi*
- dup status>> +clean+ = [
- dup current-git-id>> >>clean-git-id
- dup current-timestamp>> >>clean-timestamp
- ] when
- dup current-git-id>> >>last-git-id
- dup current-timestamp>> >>last-timestamp
- drop ;
-
-: release ( builder name -- )
- >>last-release
- dup clean-git-id>> >>release-git-id
- drop ;
-
-: update-builder ( builder -- )
- message get {
- { "git-id" [ message-arg get git-id ] }
- { "make-vm" [ make-vm ] }
- { "boot" [ boot ] }
- { "test" [ test ] }
- { "report" [ message-arg get contents report ] }
- { "release" [ message-arg get release ] }
- } case ;
-
-: mason-db ( -- db ) "resource:mason.db" <sqlite-db> ;
-
-: handle-update ( command-line timestamp -- )
- mason-db [
- [ parse-args find-builder ] dip >>current-timestamp
- [ update-builder ] [ update-tuple ] bi
- ] with-db ;
-
-CONSTANT: log-file "resource:mason.log"
-
-: log-update ( command-line timestamp -- )
- log-file utf8 [
- present write ": " write " " join print
- ] with-file-appender ;
-
-: main ( -- )
- command-line get now [ log-update ] [ handle-update ] 2bi ;
-
-MAIN: main
: base-name ( -- string )
[ "factor-" % platform % "-" % stamp get % ] "" make ;
-: extension ( -- extension )
- target-os get {
+: extension ( os -- extension )
+ {
{ "winnt" [ ".zip" ] }
{ "macosx" [ ".dmg" ] }
[ drop ".tar.gz" ]
} case ;
-: archive-name ( -- string ) base-name extension append ;
+: archive-name ( -- string ) base-name target-os get extension append ;
:: make-windows-archive ( archive-name -- )
{ "zip" "-r" archive-name "factor" } short-running-process ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators combinators.smart command-line db
+db.sqlite db.tuples db.types io io.encodings.utf8 io.files
+present kernel namespaces sequences calendar ;
+IN: mason.notify.server
+
+CONSTANT: +starting+ "starting"
+CONSTANT: +make-vm+ "make-vm"
+CONSTANT: +boot+ "boot"
+CONSTANT: +test+ "test"
+CONSTANT: +clean+ "status-clean"
+CONSTANT: +dirty+ "status-dirty"
+CONSTANT: +error+ "status-error"
+
+TUPLE: builder
+host-name os cpu
+clean-git-id clean-timestamp
+last-release release-git-id
+last-git-id last-timestamp last-report
+current-git-id current-timestamp
+status ;
+
+builder "BUILDERS" {
+ { "host-name" "HOST_NAME" TEXT +user-assigned-id+ }
+ { "os" "OS" TEXT +user-assigned-id+ }
+ { "cpu" "CPU" TEXT +user-assigned-id+ }
+
+ { "clean-git-id" "CLEAN_GIT_ID" TEXT }
+ { "clean-timestamp" "CLEAN_TIMESTAMP" TIMESTAMP }
+
+ { "last-release" "LAST_RELEASE" TEXT }
+ { "release-git-id" "RELEASE_GIT_ID" TEXT }
+
+ { "last-git-id" "LAST_GIT_ID" TEXT }
+ { "last-timestamp" "LAST_TIMESTAMP" TIMESTAMP }
+ { "last-report" "LAST_REPORT" TEXT }
+
+ { "current-git-id" "CURRENT_GIT_ID" TEXT }
+ ! Can't name it CURRENT_TIMESTAMP because of bug in db library
+ { "current-timestamp" "CURR_TIMESTAMP" TIMESTAMP }
+ { "status" "STATUS" TEXT }
+} define-persistent
+
+SYMBOLS: host-name target-os target-cpu message message-arg ;
+
+: parse-args ( command-line -- )
+ dup last message-arg set
+ [
+ {
+ [ host-name set ]
+ [ target-cpu set ]
+ [ target-os set ]
+ [ message set ]
+ } spread
+ ] input<sequence ;
+
+: find-builder ( -- builder )
+ builder new
+ host-name get >>host-name
+ target-os get >>os
+ target-cpu get >>cpu
+ dup select-tuple [ ] [ dup insert-tuple ] ?if ;
+
+: git-id ( builder id -- )
+ >>current-git-id +starting+ >>status drop ;
+
+: make-vm ( builder -- ) +make-vm+ >>status drop ;
+
+: boot ( builder -- ) +boot+ >>status drop ;
+
+: test ( builder -- ) +test+ >>status drop ;
+
+: report ( builder status content -- )
+ [ >>status ] [ >>last-report ] bi*
+ dup status>> +clean+ = [
+ dup current-git-id>> >>clean-git-id
+ dup current-timestamp>> >>clean-timestamp
+ ] when
+ dup current-git-id>> >>last-git-id
+ dup current-timestamp>> >>last-timestamp
+ drop ;
+
+: release ( builder name -- )
+ >>last-release
+ dup clean-git-id>> >>release-git-id
+ drop ;
+
+: update-builder ( builder -- )
+ message get {
+ { "git-id" [ message-arg get git-id ] }
+ { "make-vm" [ make-vm ] }
+ { "boot" [ boot ] }
+ { "test" [ test ] }
+ { "report" [ message-arg get contents report ] }
+ { "release" [ message-arg get release ] }
+ } case ;
+
+: mason-db ( -- db ) "resource:mason.db" <sqlite-db> ;
+
+: handle-update ( command-line timestamp -- )
+ mason-db [
+ [ parse-args find-builder ] dip >>current-timestamp
+ [ update-builder ] [ update-tuple ] bi
+ ] with-db ;
+
+CONSTANT: log-file "resource:mason.log"
+
+: log-update ( command-line timestamp -- )
+ log-file utf8 [
+ present write ": " write " " join print
+ ] with-file-appender ;
+
+: main ( -- )
+ command-line get now [ log-update ] [ handle-update ] 2bi ;
+
+MAIN: main
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors calendar db db.tuples grouping io
+io.encodings.ascii io.launcher kernel locals make
+mason.release.archive mason.server namespaces sequences ;
+IN: mason.server.release
+
+! Host to upload binary package to.
+SYMBOL: upload-host
+
+! Username to log in.
+SYMBOL: upload-username
+
+! Directory with binary packages.
+SYMBOL: upload-directory
+
+: platform ( builder -- string )
+ [ os>> ] [ cpu>> ] bi "-" glue ;
+
+: package-name ( builder -- string )
+ [ platform ] [ last-release>> ] bi "/" glue ;
+
+: release-name ( version builder -- string )
+ [
+ "releases/" %
+ [ platform % "/" % ]
+ [ "factor-" % platform % "-" % % ]
+ [ os>> extension % ]
+ tri
+ ] "" make ;
+
+: release-command ( version builder -- command )
+ [
+ "ln -s " %
+ [ nip package-name % " " % ] [ release-name % ] 2bi
+ ] { } make ;
+
+TUPLE: release
+host-name os cpu
+last-release release-git-id ;
+
+:: <release> ( version builder -- release )
+ release new
+ builder host-name>> >>host-name
+ builder os>> >>os
+ builder cpu>> >>cpu
+ builder release-git-id>> >>release-git-id
+ version builder release-name >>last-release ;
+
+: execute-on-server ( string -- )
+ [ "ssh" , upload-host get , "-l" , upload-username get , ] { } make
+ <process>
+ swap >>command
+ 30 seconds >>timeout
+ ascii [ write ] with-process-writer ;
+
+: release-script ( version builders -- string )
+ upload-directory get "cd " "\n" surround prepend
+ [ release-command ] with map "\n" join ;
+
+: create-releases ( version builders -- )
+ release-script execute-on-server ;
+
+: update-releases ( version builders -- )
+ [
+ release new delete-tuples
+ [ <release> insert-tuple ] with each
+ ] with-transaction ;
+
+: check-releases ( builders -- )
+ [ release-git-id>> ] map all-equal?
+ [ "Not all builders are up to date" throw ] unless ;
+
+: do-release ( version -- )
+ [
+ builder new select-tuples
+ [ nip check-releases ]
+ [ create-releases ]
+ [ update-releases ]
+ 2tri
+ ] with-mason-db ;
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: db db.sqlite db.tuples db.types kernel ;
+IN: mason.server
+
+CONSTANT: +starting+ "starting"
+CONSTANT: +make-vm+ "make-vm"
+CONSTANT: +boot+ "boot"
+CONSTANT: +test+ "test"
+CONSTANT: +clean+ "status-clean"
+CONSTANT: +dirty+ "status-dirty"
+CONSTANT: +error+ "status-error"
+
+TUPLE: builder
+host-name os cpu
+clean-git-id clean-timestamp
+last-release release-git-id
+last-git-id last-timestamp last-report
+current-git-id current-timestamp
+status ;
+
+builder "BUILDERS" {
+ { "host-name" "HOST_NAME" TEXT +user-assigned-id+ }
+ { "os" "OS" TEXT +user-assigned-id+ }
+ { "cpu" "CPU" TEXT +user-assigned-id+ }
+
+ { "clean-git-id" "CLEAN_GIT_ID" TEXT }
+ { "clean-timestamp" "CLEAN_TIMESTAMP" TIMESTAMP }
+
+ { "last-release" "LAST_RELEASE" TEXT }
+ { "release-git-id" "RELEASE_GIT_ID" TEXT }
+
+ { "last-git-id" "LAST_GIT_ID" TEXT }
+ { "last-timestamp" "LAST_TIMESTAMP" TIMESTAMP }
+ { "last-report" "LAST_REPORT" TEXT }
+
+ { "current-git-id" "CURRENT_GIT_ID" TEXT }
+ ! Can't name it CURRENT_TIMESTAMP because of bug in db library
+ { "current-timestamp" "CURR_TIMESTAMP" TIMESTAMP }
+ { "status" "STATUS" TEXT }
+} define-persistent
+
+: mason-db ( -- db ) "resource:mason.db" <sqlite-db> ;
+
+: with-mason-db ( quot -- )
+ [ mason-db ] dip with-db ; inline
projects / factor.git / commitdiff