From 74107f2acd9f466f629abd7f93f703bcd1e2318b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 18 May 2009 23:45:52 -0500 Subject: [PATCH 01/10] fix some duplicate using lines --- basis/furnace/actions/actions.factor | 1 - extra/galois-talk/galois-talk.factor | 2 +- extra/minneapolis-talk/minneapolis-talk.factor | 2 +- 3 files changed, 2 insertions(+), 3 deletions(-) diff --git a/basis/furnace/actions/actions.factor b/basis/furnace/actions/actions.factor index c7893117d1..06e743e967 100644 --- a/basis/furnace/actions/actions.factor +++ b/basis/furnace/actions/actions.factor @@ -12,7 +12,6 @@ furnace.conversations furnace.chloe-tags html.forms html.components -html.components html.templates.chloe html.templates.chloe.syntax html.templates.chloe.compiler ; diff --git a/extra/galois-talk/galois-talk.factor b/extra/galois-talk/galois-talk.factor index ba929867e9..0d2a5a73d8 100644 --- a/extra/galois-talk/galois-talk.factor +++ b/extra/galois-talk/galois-talk.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: slides help.markup math arrays hashtables namespaces -sequences kernel sequences parser memoize io.encodings.binary +sequences kernel parser memoize io.encodings.binary locals kernel.private help.vocabs assocs quotations urls peg.ebnf tools.annotations tools.crossref help.topics math.functions compiler.tree.optimizer diff --git a/extra/minneapolis-talk/minneapolis-talk.factor b/extra/minneapolis-talk/minneapolis-talk.factor index 6f1df44bfb..a96bb2ce20 100755 --- a/extra/minneapolis-talk/minneapolis-talk.factor +++ b/extra/minneapolis-talk/minneapolis-talk.factor @@ -1,5 +1,5 @@ USING: slides help.markup math arrays hashtables namespaces -sequences kernel sequences parser memoize ; +sequences kernel parser memoize ; IN: minneapolis-talk CONSTANT: minneapolis-slides From 8f688eb742a12522e9ed94f038fca89cae13fc7f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 20 May 2009 15:50:01 -0500 Subject: [PATCH 02/10] fix comments and dtds in html parser --- extra/html/parser/parser-tests.factor | 23 +++++++++++++++++++++++ extra/html/parser/parser.factor | 8 +++++--- 2 files changed, 28 insertions(+), 3 deletions(-) diff --git a/extra/html/parser/parser-tests.factor b/extra/html/parser/parser-tests.factor index ca276fc54e..2876d03b16 100644 --- a/extra/html/parser/parser-tests.factor +++ b/extra/html/parser/parser-tests.factor @@ -73,3 +73,26 @@ V{ T{ tag f "head" H{ } f t } } ] [ "Spagna" + parse-html +] unit-test + +[ +V{ + T{ tag { name comment } { text "comment" } } +} +] [ + "" parse-html +] unit-test diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor index d95c79dd88..948bd0c954 100644 --- a/extra/html/parser/parser.factor +++ b/extra/html/parser/parser.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays hashtables sequence-parser -html.parser.utils kernel namespaces sequences +html.parser.utils kernel namespaces sequences math unicode.case unicode.categories combinators.short-circuit quoting fry ; IN: html.parser @@ -63,10 +63,12 @@ SYMBOL: tagstack [ blank? ] trim ; : read-comment ( sequence-parser -- ) - "-->" take-until-sequence comment new-tag push-tag ; + [ "-->" take-until-sequence comment new-tag push-tag ] + [ '[ _ advance drop ] 3 swap times ] bi ; : read-dtd ( sequence-parser -- ) - ">" take-until-sequence dtd new-tag push-tag ; + [ ">" take-until-sequence dtd new-tag push-tag ] + [ advance drop ] bi ; : read-bang ( sequence-parser -- ) advance dup { [ current CHAR: - = ] [ peek-next CHAR: - = ] } 1&& From 0c05f5f3292f461c21ac239deeed9d4c5de1b797 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 20 May 2009 18:51:01 -0500 Subject: [PATCH 03/10] windows.advapi32: add windows.kernel32 dependency --- basis/windows/advapi32/advapi32.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) mode change 100644 => 100755 basis/windows/advapi32/advapi32.factor diff --git a/basis/windows/advapi32/advapi32.factor b/basis/windows/advapi32/advapi32.factor old mode 100644 new mode 100755 index fd037cb2a0..1ba08e657b --- a/basis/windows/advapi32/advapi32.factor +++ b/basis/windows/advapi32/advapi32.factor @@ -1,4 +1,5 @@ -USING: alien.syntax kernel math windows.types math.bitwise ; +USING: alien.syntax kernel math windows.types windows.kernel32 +math.bitwise ; IN: windows.advapi32 LIBRARY: advapi32 From 610b276c861cd67522becc2484e18d7863dd84ce Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 20 May 2009 18:52:21 -0500 Subject: [PATCH 04/10] callstack>array primitive was not GC safe --- vm/callstack.cpp | 36 +++++++++++++++++------------------- vm/callstack.hpp | 14 ++++++++++++-- vm/layouts.hpp | 5 +++++ 3 files changed, 34 insertions(+), 21 deletions(-) diff --git a/vm/callstack.cpp b/vm/callstack.cpp index 608a5c39e5..38fb1e2b33 100755 --- a/vm/callstack.cpp +++ b/vm/callstack.cpp @@ -107,8 +107,9 @@ stack_frame *frame_successor(stack_frame *frame) /* Allocates memory */ cell frame_scan(stack_frame *frame) { - if(frame_type(frame) == QUOTATION_TYPE) + switch(frame_type(frame)) { + case QUOTATION_TYPE: cell quot = frame_executing(frame); if(quot == F) return F; @@ -120,28 +121,27 @@ cell frame_scan(stack_frame *frame) return tag_fixnum(quot_code_offset_to_scan( quot,(cell)(return_addr - quot_xt))); } - } - else + case WORD_TYPE: return F; + default: + critical_error("Bad frame type",frame_type(frame)); + return F; + } } namespace { -struct stack_frame_counter { - cell count; - stack_frame_counter() : count(0) {} - void operator()(stack_frame *frame) { count += 2; } -}; - struct stack_frame_accumulator { - cell index; - gc_root frames; - stack_frame_accumulator(cell count) : index(0), frames(allot_array(count,F)) {} + growable_array frames; + void operator()(stack_frame *frame) { - set_array_nth(frames.untagged(),index++,frame_executing(frame)); - set_array_nth(frames.untagged(),index++,frame_scan(frame)); + gc_root executing(frame_executing(frame)); + gc_root scan(frame_scan(frame)); + + frames.add(executing.value()); + frames.add(scan.value()); } }; @@ -151,13 +151,11 @@ PRIMITIVE(callstack_to_array) { gc_root callstack(dpop()); - stack_frame_counter counter; - iterate_callstack_object(callstack.untagged(),counter); - - stack_frame_accumulator accum(counter.count); + stack_frame_accumulator accum; iterate_callstack_object(callstack.untagged(),accum); + accum.frames.trim(); - dpush(accum.frames.value()); + dpush(accum.frames.elements.value()); } stack_frame *innermost_stack_frame(callstack *stack) diff --git a/vm/callstack.hpp b/vm/callstack.hpp index d92e5f69e0..a3cc058e2b 100755 --- a/vm/callstack.hpp +++ b/vm/callstack.hpp @@ -33,9 +33,19 @@ template void iterate_callstack(cell top, cell bottom, T &iterator) } } -template void iterate_callstack_object(callstack *stack, T &iterator) +/* This is a little tricky. The iterator may allocate memory, so we +keep the callstack in a GC root and use relative offsets */ +template void iterate_callstack_object(callstack *stack_, T &iterator) { - iterate_callstack((cell)stack->top(),(cell)stack->bottom(),iterator); + gc_root stack(stack_); + fixnum frame_offset = untag_fixnum(stack->length) - sizeof(stack_frame); + + while(frame_offset >= 0) + { + stack_frame *frame = stack->frame_at(frame_offset); + frame_offset -= frame->size; + iterator(frame); + } } } diff --git a/vm/layouts.hpp b/vm/layouts.hpp index 3fe89cb558..7736143c50 100755 --- a/vm/layouts.hpp +++ b/vm/layouts.hpp @@ -309,6 +309,11 @@ struct callstack : public object { /* tagged */ cell length; + stack_frame *frame_at(cell offset) + { + return (stack_frame *)((char *)(this + 1) + offset); + } + stack_frame *top() { return (stack_frame *)(this + 1); } stack_frame *bottom() { return (stack_frame *)((cell)(this + 1) + untag_fixnum(length)); } }; From 6b2192bde0dfc9ee36ebe432793e707164638537 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 20 May 2009 20:01:21 -0400 Subject: [PATCH 05/10] Fix compile error on GCC 4.x --- vm/callstack.cpp | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/vm/callstack.cpp b/vm/callstack.cpp index 38fb1e2b33..39988ae976 100755 --- a/vm/callstack.cpp +++ b/vm/callstack.cpp @@ -110,16 +110,18 @@ cell frame_scan(stack_frame *frame) switch(frame_type(frame)) { case QUOTATION_TYPE: - cell quot = frame_executing(frame); - if(quot == F) - return F; - else { - char *return_addr = (char *)FRAME_RETURN_ADDRESS(frame); - char *quot_xt = (char *)(frame_code(frame) + 1); + cell quot = frame_executing(frame); + if(quot == F) + return F; + else + { + char *return_addr = (char *)FRAME_RETURN_ADDRESS(frame); + char *quot_xt = (char *)(frame_code(frame) + 1); - return tag_fixnum(quot_code_offset_to_scan( - quot,(cell)(return_addr - quot_xt))); + return tag_fixnum(quot_code_offset_to_scan( + quot,(cell)(return_addr - quot_xt))); + } } case WORD_TYPE: return F; From 91834fb3360445c4574552bb1fd0eb5b43caa747 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 20 May 2009 19:30:35 -0500 Subject: [PATCH 06/10] fix error handling in random.windows if acquiring the crypto context fails --- basis/random/windows/windows.factor | 46 +++++++++++++++++--------- basis/windows/advapi32/advapi32.factor | 34 +++++++++++++++++++ 2 files changed, 65 insertions(+), 15 deletions(-) diff --git a/basis/random/windows/windows.factor b/basis/random/windows/windows.factor index 488deef41f..981b8ec14e 100644 --- a/basis/random/windows/windows.factor +++ b/basis/random/windows/windows.factor @@ -1,6 +1,7 @@ -USING: accessors alien.c-types byte-arrays continuations -kernel windows.advapi32 init namespaces random destructors -locals windows.errors ; +USING: accessors alien.c-types byte-arrays +combinators.short-circuit continuations destructors init kernel +locals namespaces random windows.advapi32 windows.errors +windows.kernel32 ; IN: random.windows TUPLE: windows-rng provider type ; @@ -12,22 +13,37 @@ C: windows-crypto-context M: windows-crypto-context dispose ( tuple -- ) handle>> 0 CryptReleaseContext win32-error=0/f ; -: factor-crypto-container ( -- string ) "FactorCryptoContainer" ; inline +CONSTANT: factor-crypto-container "FactorCryptoContainer" -:: (acquire-crypto-context) ( provider type flags -- handle ) - [let | handle [ "HCRYPTPROV" ] | - handle - factor-crypto-container - provider - type - flags - CryptAcquireContextW win32-error=0/f - handle *void* ] ; +:: (acquire-crypto-context) ( provider type flags -- handle ret ) + "HCRYPTPROV" :> handle + handle + factor-crypto-container + provider + type + flags + CryptAcquireContextW handle swap ; : acquire-crypto-context ( provider type -- handle ) - [ 0 (acquire-crypto-context) ] - [ drop CRYPT_NEWKEYSET (acquire-crypto-context) ] recover ; + 0 (acquire-crypto-context) + 0 = [ + GetLastError NTE_BAD_KEYSET = + [ drop f ] [ win32-error-string throw ] if + ] [ + *void* + ] if ; +: create-crypto-context ( provider type -- handle ) + CRYPT_NEWKEYSET (acquire-crypto-context) win32-error=0/f *void* ; + +ERROR: acquire-crypto-context-failed provider type ; + +: attempt-crypto-context ( provider type -- handle ) + { + [ acquire-crypto-context ] + [ create-crypto-context ] + [ acquire-crypto-context-failed ] + } 2|| ; : windows-crypto-context ( provider type -- context ) acquire-crypto-context ; diff --git a/basis/windows/advapi32/advapi32.factor b/basis/windows/advapi32/advapi32.factor index fd037cb2a0..6e040871f8 100644 --- a/basis/windows/advapi32/advapi32.factor +++ b/basis/windows/advapi32/advapi32.factor @@ -291,6 +291,40 @@ CONSTANT: SE_GROUP_ENABLED 4 CONSTANT: SE_GROUP_OWNER 8 CONSTANT: SE_GROUP_LOGON_ID -1073741824 +CONSTANT: NTE_BAD_UID HEX: 80090001 +CONSTANT: NTE_BAD_HASH HEX: 80090002 +CONSTANT: NTE_BAD_KEY HEX: 80090003 +CONSTANT: NTE_BAD_LEN HEX: 80090004 +CONSTANT: NTE_BAD_DATA HEX: 80090005 +CONSTANT: NTE_BAD_SIGNATURE HEX: 80090006 +CONSTANT: NTE_BAD_VER HEX: 80090007 +CONSTANT: NTE_BAD_ALGID HEX: 80090008 +CONSTANT: NTE_BAD_FLAGS HEX: 80090009 +CONSTANT: NTE_BAD_TYPE HEX: 8009000A +CONSTANT: NTE_BAD_KEY_STATE HEX: 8009000B +CONSTANT: NTE_BAD_HASH_STATE HEX: 8009000C +CONSTANT: NTE_NO_KEY HEX: 8009000D +CONSTANT: NTE_NO_MEMORY HEX: 8009000E +CONSTANT: NTE_EXISTS HEX: 8009000F +CONSTANT: NTE_PERM HEX: 80090010 +CONSTANT: NTE_NOT_FOUND HEX: 80090011 +CONSTANT: NTE_DOUBLE_ENCRYPT HEX: 80090012 +CONSTANT: NTE_BAD_PROVIDER HEX: 80090013 +CONSTANT: NTE_BAD_PROV_TYPE HEX: 80090014 +CONSTANT: NTE_BAD_PUBLIC_KEY HEX: 80090015 +CONSTANT: NTE_BAD_KEYSET HEX: 80090016 +CONSTANT: NTE_PROV_TYPE_NOT_DEF HEX: 80090017 +CONSTANT: NTE_PROV_TYPE_ENTRY_BAD HEX: 80090018 +CONSTANT: NTE_KEYSET_NOT_DEF HEX: 80090019 +CONSTANT: NTE_KEYSET_ENTRY_BAD HEX: 8009001A +CONSTANT: NTE_PROV_TYPE_NO_MATCH HEX: 8009001B +CONSTANT: NTE_SIGNATURE_FILE_BAD HEX: 8009001C +CONSTANT: NTE_PROVIDER_DLL_FAIL HEX: 8009001D +CONSTANT: NTE_PROV_DLL_NOT_FOUND HEX: 8009001E +CONSTANT: NTE_BAD_KEYSET_PARAM HEX: 8009001F +CONSTANT: NTE_FAIL HEX: 80090020 +CONSTANT: NTE_SYS_ERR HEX: 80090021 + ! SID is a variable length structure TYPEDEF: void* PSID From 52e959e6a1920ea5df3a40f2da8e632d187b74d7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 20 May 2009 19:40:52 -0500 Subject: [PATCH 07/10] call the word that attempts both crypto contexts --- basis/random/windows/windows.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/random/windows/windows.factor b/basis/random/windows/windows.factor index 981b8ec14e..c8e08c9abe 100644 --- a/basis/random/windows/windows.factor +++ b/basis/random/windows/windows.factor @@ -46,7 +46,7 @@ ERROR: acquire-crypto-context-failed provider type ; } 2|| ; : windows-crypto-context ( provider type -- context ) - acquire-crypto-context ; + attempt-crypto-context ; M: windows-rng random-bytes* ( n tuple -- bytes ) [ From ef3656aea866e1983ebdd9786fe0eb7b038459cf Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 20 May 2009 20:06:05 -0500 Subject: [PATCH 08/10] try to fall back on AES if RSA isn't found --- basis/random/windows/windows.factor | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/basis/random/windows/windows.factor b/basis/random/windows/windows.factor index c8e08c9abe..aa9404fbb2 100644 --- a/basis/random/windows/windows.factor +++ b/basis/random/windows/windows.factor @@ -60,9 +60,13 @@ M: windows-rng random-bytes* ( n tuple -- bytes ) MS_DEF_PROV PROV_RSA_FULL system-random-generator set-global - MS_STRONG_PROV - PROV_RSA_FULL secure-random-generator set-global + [ + MS_STRONG_PROV + PROV_RSA_FULL secure-random-generator set-global + ] [ + drop + MS_ENH_RSA_AES_PROV + PROV_RSA_AES secure-random-generator set-global + ] recover - ! MS_ENH_RSA_AES_PROV - ! PROV_RSA_AES secure-random-generator set-global ] "random.windows" add-init-hook From 57d38b1dd0dcf04edc562307440f9e5cce14f764 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 20 May 2009 20:08:26 -0500 Subject: [PATCH 09/10] better factoring --- basis/random/windows/windows.factor | 11 +++-------- 1 file changed, 3 insertions(+), 8 deletions(-) diff --git a/basis/random/windows/windows.factor b/basis/random/windows/windows.factor index aa9404fbb2..6dce078d67 100644 --- a/basis/random/windows/windows.factor +++ b/basis/random/windows/windows.factor @@ -60,13 +60,8 @@ M: windows-rng random-bytes* ( n tuple -- bytes ) MS_DEF_PROV PROV_RSA_FULL system-random-generator set-global - [ - MS_STRONG_PROV - PROV_RSA_FULL secure-random-generator set-global - ] [ - drop - MS_ENH_RSA_AES_PROV - PROV_RSA_AES secure-random-generator set-global - ] recover + [ MS_STRONG_PROV PROV_RSA_FULL ] + [ drop MS_ENH_RSA_AES_PROV PROV_RSA_AES ] recover + secure-random-generator set-global ] "random.windows" add-init-hook From 7d328011e8c3c9c23fa8ec9d4f8c036384171261 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 21 May 2009 00:08:43 -0500 Subject: [PATCH 10/10] Working on webapps.mason --- basis/io/launcher/launcher.factor | 2 +- extra/mason/common/common.factor | 11 +- extra/mason/notify/notify.factor | 6 +- extra/mason/notify/server/server.factor | 55 ++++++++-- extra/mason/report/report.factor | 28 ++--- extra/webapps/mason/download.xml | 23 ++++ extra/webapps/mason/mason.factor | 138 +++++++++++++++++++----- 7 files changed, 202 insertions(+), 61 deletions(-) create mode 100644 extra/webapps/mason/download.xml diff --git a/basis/io/launcher/launcher.factor b/basis/io/launcher/launcher.factor index 7451499978..f4978672d9 100755 --- 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 [ 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 index 4ac5767009..d54a17ff91 100755 --- 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 index ccabccdf8b..87447e48cc 100644 --- a/extra/mason/notify/notify.factor +++ b/extra/mason/notify/notify.factor @@ -16,7 +16,7 @@ IN: mason.notify ] { } make prepend [ 5 ] 2dip '[ - _ [ +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 index cc055e38d8..9ed29aef45 100644 --- 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" +CONSTANT: +clean+ "status-clean" +CONSTANT: +dirty+ "status-dirty" +CONSTANT: +error+ "status-error" -TUPLE: builder host-name os cpu clean-git-id last-git-id last-report current-git-id status ; +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" ; -: 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 index e74db9a1ae..52237171cf 100644 --- 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 <-><-> 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 ? ; \ No newline at end of file diff --git a/extra/webapps/mason/download.xml b/extra/webapps/mason/download.xml new file mode 100644 index 0000000000..2b1bb76f64 --- /dev/null +++ b/extra/webapps/mason/download.xml @@ -0,0 +1,23 @@ + + + + + + + Factor binary package for <t:label t:name="platform" /> + + +

Factor binary package for

+ +

Requirements:

+ + +

Download

+ +

This package was built from GIT ID .

+ +

Once you download Factor, you can get started with the language.

+ + + + diff --git a/extra/webapps/mason/mason.factor b/extra/webapps/mason/mason.factor index 74c459e38e..7e76de736d 100644 --- a/extra/webapps/mason/mason.factor +++ b/extra/webapps/mason/mason.factor @@ -1,11 +1,28 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays combinators db db.tuples furnace.actions -http.server.responses kernel mason.platform mason.notify.server -mason.report math.order sequences sorting splitting xml.syntax -xml.writer io.pathnames io.encodings.utf8 io.files ; +http.server.responses http.server.dispatchers kernel mason.platform +mason.notify.server mason.report math.order sequences sorting +splitting xml.syntax xml.writer io.pathnames io.encodings.utf8 +io.files present validators html.forms furnace.db assocs urls ; IN: webapps.mason +TUPLE: mason-app < dispatcher ; + +: validate-os/cpu ( -- ) + { + { "os" [ v-one-line ] } + { "cpu" [ v-one-line ] } + } validate-params ; + +: current-builder ( -- builder ) + builder new "os" value >>os "cpu" value >>cpu select-tuple ; + +: ( -- action ) + + [ validate-os/cpu ] >>init + [ current-builder last-report>> "text/html" ] >>display ; + : log-file ( -- path ) home "mason.log" append-path ; : recent-events ( -- xml ) @@ -20,24 +37,48 @@ IN: webapps.mason [XML <-> for <-> XML] ; : current-status ( builder -- xml ) - dup status>> { - { "status-dirty" [ drop "Dirty" ] } - { "status-clean" [ drop "Clean" ] } - { "status-error" [ drop "Error" ] } - { "starting" [ "Starting" building ] } - { "make-vm" [ "Compiling VM" building ] } - { "boot" [ "Bootstrapping" building ] } - { "test" [ "Testing" building ] } - [ 2drop "Unknown" ] - } case ; + [ + dup status>> { + { +dirty+ [ drop "Dirty" ] } + { +clean+ [ drop "Clean" ] } + { +error+ [ drop "Error" ] } + { +starting+ [ "Starting build" building ] } + { +make-vm+ [ "Compiling VM" building ] } + { +boot+ [ "Bootstrapping" building ] } + { +test+ [ "Testing" building ] } + [ 2drop "Unknown" ] + } case + ] [ current-timestamp>> present " (as of " ")" surround ] bi 2array ; + +: build-status ( git-id timestamp -- xml ) + over [ [ git-link ] [ present ] bi* " (built on " ")" surround 2array ] [ 2drop f ] if ; + +: binaries-url ( builder -- url ) + [ os>> ] [ cpu>> ] bi (platform) "http://downloads.factorcode.org/" prepend ; + +: url-link ( url -- xml ) + dup [XML ><-> XML] ; + +: latest-binary-link ( builder -- xml ) + [ URL" download" ] dip + [ os>> "os" set-query-param ] + [ cpu>> "cpu" set-query-param ] bi + [XML >Latest download XML] ; : binaries-link ( builder -- link ) - [ os>> ] [ cpu>> ] bi (platform) "http://downloads.factorcode.org/" prepend - dup [XML ><-> XML] ; + binaries-url url-link ; + +: clean-image-url ( builder -- url ) + [ os>> ] [ cpu>> ] bi (platform) "http://factorcode.org/images/clean/" prepend ; : clean-image-link ( builder -- link ) - [ os>> ] [ cpu>> ] bi (platform) "http://factorcode.org/images/clean/" prepend - dup [XML ><-> XML] ; + clean-image-url url-link ; + +: report-link ( builder -- xml ) + [ URL" report" ] dip + [ os>> "os" set-query-param ] + [ cpu>> "cpu" set-query-param ] bi + [XML >Latest build report XML] ; : machine-table ( builder -- xml ) { @@ -45,10 +86,12 @@ IN: webapps.mason [ cpu>> ] [ host-name>> "." split1 drop ] [ current-status ] - [ last-git-id>> dup [ git-link ] when ] - [ clean-git-id>> dup [ git-link ] when ] + [ [ last-git-id>> ] [ last-timestamp>> ] bi build-status ] + [ [ clean-git-id>> ] [ clean-timestamp>> ] bi build-status ] [ binaries-link ] [ clean-image-link ] + [ report-link ] + [ latest-binary-link ] } cleave [XML

<-> / <->

@@ -60,6 +103,8 @@ IN: webapps.mason Binaries:<-> Clean images:<-> + + <-> | <-> XML] ; : machine-report ( -- xml ) @@ -67,7 +112,7 @@ IN: webapps.mason [ [ [ os>> ] [ cpu>> ] bi 2array ] compare ] sort [ machine-table ] map ; -: build-farm-report ( -- xml ) +: build-farm-summary ( -- xml ) recent-events machine-report [XML @@ -77,9 +122,52 @@ IN: webapps.mason XML] ; -: ( -- action ) +: ( -- action ) - [ - mason-db [ build-farm-report xml>string ] with-db - "text/html" - ] >>display ; \ No newline at end of file + [ build-farm-summary xml>string "text/html" ] >>display ; + +TUPLE: builder-link href title ; + +C: builder-link + +: requirements ( builder -- xml ) + [ + os>> { + { "winnt" "Windows XP (also tested on Vista)" } + { "macosx" "Mac OS X 10.5 Leopard" } + { "linux" "Linux 2.6.16 with GLIBC 2.4" } + { "freebsd" "FreeBSD 7.0" } + { "netbsd" "NetBSD 4.0" } + { "openbsd" "OpenBSD 4.2" } + } at + ] [ + dup cpu>> "x86-32" = [ + os>> { + { [ dup { "winnt" "linux" } member? ] [ drop "Intel Pentium 4, Core Duo, or other x86 chip with SSE2 support. Note that 32-bit Athlon XP processors do not support SSE2." ] } + { [ dup { "freebsd" "netbsd" "openbsd" } member? ] [ drop "Intel Pentium Pro or better" ] } + { [ t ] [ drop f ] } + } cond + ] [ drop f ] if + ] bi + 2array sift [ [XML
  • <->
    • XML] ] map [XML
      <->
    XML] ; + +: ( -- action ) + + [ + validate-os/cpu + "os" value "cpu" value (platform) "platform" set-value + current-builder + [ latest-binary-link "package" set-value ] + [ release-git-id>> git-link "git-id" set-value ] + [ requirements "requirements" set-value ] + tri + ] >>init + { mason-app "download" } >>template ; + +: ( -- dispatcher ) + mason-app new-dispatcher + "" add-responder + "report" add-responder + "download" add-responder + mason-db ; +