diff --git a/extra/mason/release/archive/archive.factor b/extra/mason/release/archive/archive.factor index 51534edccd..ceec84e475 100644 --- a/extra/mason/release/archive/archive.factor +++ b/extra/mason/release/archive/archive.factor @@ -9,14 +9,14 @@ IN: mason.release.archive : 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 ; diff --git a/extra/mason/notify/server/authors.txt b/extra/mason/server/authors.txt similarity index 100% rename from extra/mason/notify/server/authors.txt rename to extra/mason/server/authors.txt diff --git a/extra/mason/server/notify/authors.txt b/extra/mason/server/notify/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/mason/server/notify/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/mason/notify/server/server.factor b/extra/mason/server/notify/notify.factor similarity index 100% rename from extra/mason/notify/server/server.factor rename to extra/mason/server/notify/notify.factor diff --git a/extra/mason/server/release/authors.txt b/extra/mason/server/release/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/mason/server/release/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/mason/server/release/release.factor b/extra/mason/server/release/release.factor new file mode 100644 index 0000000000..2683d642de --- /dev/null +++ b/extra/mason/server/release/release.factor @@ -0,0 +1,81 @@ +! 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 ; + +:: ( 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 + + 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 + [ 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 ; diff --git a/extra/mason/server/server.factor b/extra/mason/server/server.factor new file mode 100644 index 0000000000..d0fe29b917 --- /dev/null +++ b/extra/mason/server/server.factor @@ -0,0 +1,46 @@ +! 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" ; + +: with-mason-db ( quot -- ) + [ mason-db ] dip with-db ; inline