Working on webapps.mason

factor · May 21, 2009 · 7d32801 · 7d32801
1 parent 2d81d08
commit 7d32801
Show file tree

Hide file tree

Showing 7 changed files with 203 additions and 62 deletions.
diff --git a/basis/io/launcher/launcher.factor b/basis/io/launcher/launcher.factor
@@ -264,7 +264,7 @@ M: output-process-error error.
 : try-output-process ( command -- )
     >process
     +stdout+ >>stderr
-    +closed+ >>stdin
+    [ +closed+ or ] change-stdin
     utf8 <process-reader*>
     [ stream-contents ] [ dup wait-for-process ] bi*
     0 = [ 2drop ] [ output-process-error ] if ;

diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
+! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel namespaces sequences splitting system accessors
 math.functions make io io.files io.pathnames io.directories
@@ -13,10 +13,7 @@ SYMBOL: current-git-id
 : short-running-process ( command -- )
     #! Give network operations and shell commands at most
     #! 15 minutes to complete, to catch hangs.
-    >process
-        15 minutes >>timeout
-        +closed+ >>stdin
-    try-output-process ;
+    >process 15 minutes >>timeout try-output-process ;
 
 HOOK: really-delete-tree os ( path -- )
 
@@ -45,10 +42,6 @@ M: unix really-delete-tree delete-tree ;
     dup utf8 file-lines parse-fresh
     [ "Empty file: " swap append throw ] [ nip first ] if-empty ;
 
-: cat ( file -- ) utf8 file-contents print ;
-
-: cat-n ( file n -- ) [ utf8 file-lines ] dip short tail* [ print ] each ;
-
 : to-file ( object file -- ) utf8 [ . ] with-file-writer ;
 
 : datestamp ( timestamp -- string )

diff --git a/extra/mason/notify/notify.factor b/extra/mason/notify/notify.factor
@@ -16,7 +16,7 @@ IN: mason.notify
         ] { } make prepend
         [ 5 ] 2dip '[
             <process>
-                _ [ +closed+ ] unless* >>stdin
+                _ >>stdin
                 _ >>command
             short-running-process
         ] retry
@@ -49,4 +49,6 @@ IN: mason.notify
     ] bi ;
 
 : notify-release ( archive-name -- )
-    "Uploaded " prepend [ print flush ] [ mason-tweet ] bi ;
+    [ "Uploaded " prepend [ print flush ] [ mason-tweet ] bi ]
+    [ f swap "release" swap 2array status-notify ]
+    bi ;
diff --git a/extra/mason/notify/server/server.factor b/extra/mason/notify/server/server.factor
@@ -1,26 +1,44 @@
 ! 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 kernel namespaces sequences ;
+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+ "clean"
-CONSTANT: +dirty+ "dirty"
-
-TUPLE: builder host-name os cpu clean-git-id last-git-id last-report current-git-id status ;
+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
 
@@ -49,14 +67,23 @@ SYMBOLS: host-name target-os target-cpu message message-arg ;
 
 : make-vm ( builder -- ) +make-vm+ >>status drop ;
 
-: boot ( report -- ) +boot+ >>status drop ;
+: boot ( builder -- ) +boot+ >>status drop ;
 
-: test ( report -- ) +test+ >>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 ] when
+    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 -- )
@@ -66,17 +93,25 @@ SYMBOLS: host-name target-os target-cpu message message-arg ;
         { "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 -- )
+: handle-update ( command-line timestamp -- )
     mason-db [
-        parse-args find-builder
+        [ 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 handle-update ;
+    command-line get now [ log-update ] [ handle-update ] 2bi ;
 
 MAIN: main
diff --git a/extra/mason/report/report.factor b/extra/mason/report/report.factor
@@ -59,13 +59,13 @@ IN: mason.report
     "test-log" "Tests failed" failed-report ;
 
 : timings-table ( -- xml )
-    {
-        $ boot-time-file
-        $ load-time-file
-        $ test-time-file
-        $ help-lint-time-file
-        $ benchmark-time-file
-        $ html-help-time-file
+    ${
+        boot-time-file
+        load-time-file
+        test-time-file
+        help-lint-time-file
+        benchmark-time-file
+        html-help-time-file
     } [
         dup eval-file milli-seconds>time
         [XML <tr><td><-></td><td><-></td></tr> XML]
@@ -121,13 +121,13 @@ IN: mason.report
     ] with-report ;
 
 : build-clean? ( -- ? )
-    {
-        [ load-all-vocabs-file eval-file empty? ]
-        [ test-all-vocabs-file eval-file empty? ]
-        [ help-lint-vocabs-file eval-file empty? ]
-        [ compiler-errors-file eval-file empty? ]
-        [ benchmark-error-vocabs-file eval-file empty? ]
-    } 0&& ;
+    ${
+        load-all-vocabs-file
+        test-all-vocabs-file
+        help-lint-vocabs-file
+        compiler-errors-file
+        benchmark-error-vocabs-file
+    } [ eval-file empty? ] all? ;
 
 : success ( -- status )
     successful-report build-clean? status-clean status-dirty ? ;
diff --git a/extra/webapps/mason/download.xml b/extra/webapps/mason/download.xml
@@ -0,0 +1,23 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+<html>
+  <head>
+    <title>Factor binary package for <t:label t:name="platform" /></title>
+  </head>
+  <body>
+    <h1>Factor binary package for <t:label t:name="platform" /></h1>
+
+    <p>Requirements:</p>
+    <t:xml t:name="requirements" />
+
+    <h2>Download <t:xml t:name="package" /></h2>
+
+    <p>This package was built from GIT ID <t:xml t:name="git-id" />.</p>
+
+    <p>Once you download Factor, you can <a href="http://concatenative.org/wiki/view/Factor/Getting started">get started</a> with the language.</p>
+  </body>
+</html>
+
+</t:chloe>