mason.server.release: work in progress

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 ;

extra/mason/server/notify/authors.txt

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

extra/mason/server/release/authors.txt

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

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

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" <sqlite-db> ;
+
+: with-mason-db ( quot -- )
+    [ mason-db ] dip with-db ; inline