Merge git://factorcode.org/git/factor

diff --git a/extra/furnace/authors.txt b/extra/furnace/authors.txt
new file mode 100644 (file)
index 0000000..f372b57
--- /dev/null
+++ b/extra/furnace/authors.txt
@@ -0,0 +1,2 @@
+Slava Pestov
+Doug Coleman

diff --git a/extra/furnace/furnace-tests.factor b/extra/furnace/furnace-tests.factor
index 85fc6c8727749f848b8b276ef72c92b4aa5734f5..6a14d40cde26173283db7f119b800ddd5ae9b404 100644 (file)
--- a/extra/furnace/furnace-tests.factor
+++ b/extra/furnace/furnace-tests.factor
@@ -28,7 +28,7 @@ TUPLE: test-tuple m n ;
     [
         H{
             { "bar" "hello" }
-        } \ foo query>quot
+        } \ foo query>seq
     ] with-scope
 ] unit-test
 

diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor
index 756fa13d1c52acc5101131976389a0e58949febc..6d6ce6b4bf96c8eb16c13aa561c8a6a214244ccf 100644 (file)
--- a/extra/furnace/furnace.factor
+++ b/extra/furnace/furnace.factor
@@ -1,48 +1,39 @@
-! Copyright (C) 2006 Slava Pestov
+! Copyright (C) 2006 Slava Pestov, Doug Coleman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel vectors io assocs quotations splitting strings 
-       words sequences namespaces arrays hashtables debugger
-       continuations tuples classes io.files 
-       http http.server.templating http.basic-authentication 
-       webapps.callback html html.elements 
-       http.server.responders furnace.validator vocabs ;
+USING: arrays assocs debugger furnace.sessions furnace.validator
+hashtables html.elements http http.server.responders
+http.server.templating
+io.files kernel namespaces quotations sequences splitting words
+strings vectors webapps.callback ;
+USING: continuations io prettyprint ;
 IN: furnace
 
-SYMBOL: default-action
+: code>quotation ( word/quot -- quot )
+    dup word? [ 1quotation ] when ;
 
+SYMBOL: default-action
 SYMBOL: template-path
 
-: define-authenticated-action ( word params realm -- )
-    pick swap "action-realm" set-word-prop
+: render-template ( template -- )
+    template-path get swap path+
+    ".furnace" append resource-path
+    run-template-file ;
+
+: define-action ( word hash -- )
     over t "action" set-word-prop
     "action-params" set-word-prop ;
 
-: define-action ( word params -- )
-    f define-authenticated-action ;
-
-: define-redirect ( word quot -- )
-    "action-redirect" set-word-prop ;
-
-: responder-vocab ( name -- vocab )
-    "webapps." swap append ;
+: define-form ( word1 word2 hash -- )
+    dupd define-action
+    swap code>quotation "form-failed" set-word-prop ;
 
-: lookup-action ( name webapp -- word )
-    responder-vocab lookup dup [
-        dup "action" word-prop [ drop f ] unless
-    ] when ;
-
-: truncate-url ( url -- action-name )
-  CHAR: / over index [ head ] when* ;
-
-: current-action ( url -- word/f )
-    dup empty? [ drop default-action get ] when
-    truncate-url "responder" get lookup-action ;
-
-PREDICATE: word action "action" word-prop ;
+: default-values ( word hash -- )
+    "default-values" set-word-prop ;
 
-: quot>query ( seq action -- hash )
-    >r >array r> "action-params" word-prop
-    [ first swap 2array ] 2map >hashtable ;
+SYMBOL: request-params
+SYMBOL: current-action
+SYMBOL: validators-errored
+SYMBOL: validation-errors
 
 : action-link ( query action -- url )
     [
@@ -52,6 +43,34 @@ PREDICATE: word action "action" word-prop ;
         word-name %
     ] "" make swap build-url ;
 
+: action-param ( hash paramsepc -- obj error/f )
+    unclip rot at swap >quotation apply-validators ;
+
+: query>seq ( hash word -- seq )
+    "action-params" word-prop [
+        dup first -rot
+        action-param [
+            t validators-errored >session
+            rot validation-errors session> set-at
+        ] [
+            nip
+        ] if*
+    ] curry* map ;
+
+: lookup-session ( hash -- session )
+    "furnace-session-id" over at* [
+        sessions get-global at
+        [ nip ] [ "furnace-session-id" over delete-at lookup-session ] if*
+    ] [
+        drop new-session rot "furnace-session-id" swap set-at
+    ] if ;
+
+: quot>query ( seq action -- hash )
+    >r >array r> "action-params" word-prop
+    [ first swap 2array ] 2map >hashtable ;
+
+PREDICATE: word action "action" word-prop ;
+
 : action-call? ( quot -- ? )
     >vector dup pop action? >r [ word? not ] all? r> and ;
 
@@ -64,62 +83,94 @@ PREDICATE: word action "action" word-prop ;
         t register-html-callback
     ] if ;
 
-: render-link ( quot name -- )
-    <a swap quot-link =href a> write </a> ;
+: replace-variables ( quot -- quot )
+    [ dup string? [ request-params session> at ] when ] map ;
 
-: action-param ( params paramspec -- obj error/f )
-    unclip rot at swap >quotation apply-validators ;
+: furnace-session-id ( -- hash )
+    "furnace-session-id" request-params session> at
+    "furnace-session-id" associate ;
 
-: query>quot ( params action -- seq )
-    "action-params" word-prop [ action-param drop ] curry* map ;
+: redirect-to-action ( -- )
+    current-action session>
+    "form-failed" word-prop replace-variables
+    quot-link furnace-session-id build-url permanent-redirect ;
 
-SYMBOL: request-params
+: if-form-page ( if then -- )
+    current-action session> "form-failed" word-prop -rot if ;
 
-: perform-redirect ( action -- )
-    "action-redirect" word-prop
-    [ dup string? [ request-params get at ] when ] map
-    [ quot-link permanent-redirect ] when* ;
+: do-action
+    current-action session> [ query>seq ] keep add >quotation call ;
 
-: (call-action) ( params action -- )
-    over request-params set
-    [ query>quot ] keep [ add >quotation call ] keep
-    perform-redirect ;
+: process-form ( -- )
+    H{ } clone validation-errors >session
+    request-params session> current-action session> query>seq
+    validators-errored session> [
+        drop redirect-to-action
+    ] [
+        current-action session> add >quotation call
+    ] if ;
+
+: page-submitted ( -- )
+    [ process-form ] [ request-params session> do-action ] if-form-page ;
+
+: action-first-time ( -- )
+    request-params session> current-action session>
+    [ "default-values" word-prop swap union request-params >session ] keep
+    request-params session> do-action ;
+
+: page-not-submitted ( -- )
+    [ redirect-to-action ] [ action-first-time ] if-form-page ;
 
-: call-action ( params action -- )
-    dup "action-realm" word-prop [
-        [ (call-action) ] with-basic-authentication
-    ] [ (call-action) ] if* ;
+: setup-call-action ( hash word -- )
+    over lookup-session session set
+    current-action >session
+    request-params session> swap union
+    request-params >session
+    f validators-errored >session ;
 
-: service-request ( params url -- )
-    current-action [
+: call-action ( hash word -- )
+    setup-call-action
+    "furnace-form-submitted" request-params session> at
+    [ page-submitted ] [ page-not-submitted ] if ;
+
+: responder-vocab ( str -- newstr )
+    "webapps." swap append ;
+
+: lookup-action ( str webapp -- word )
+    responder-vocab lookup dup [
+        dup "action" word-prop [ drop f ] unless
+    ] when ;
+
+: truncate-url ( str -- newstr )
+    CHAR: / over index [ head ] when* ;
+
+: parse-action ( str -- word/f )
+    dup empty? [ drop default-action get ] when
+    truncate-url "responder" get lookup-action ;
+
+: service-request ( hash str -- )
+    parse-action [
         [ call-action ] [ <pre> print-error </pre> ] recover
     ] [
         "404 no such action: " "argument" get append httpd-error
     ] if* ;
 
-: service-get ( url -- ) "query" get swap service-request ;
-
-: service-post ( url -- ) "response" get swap service-request ;
-
-: send-resource ( name -- )
-    template-path get swap path+ resource-path <file-reader>
-    stdio get stream-copy ;
+: service-get
+    "query" get swap service-request ;
 
-: render-template ( template -- )
-    template-path get swap path+
-    ".furnace" append resource-path
-    run-template-file ;
+: service-post
+    "response" get swap service-request ;
 
-: web-app ( name default path -- )
+: web-app ( name defaul path -- )
     [
         template-path set
         default-action set
         "responder" set
         [ service-get ] "get" set
         [ service-post ] "post" set
-        ! [ service-head ] "head" set
     ] make-responder ;
 
+USING: classes html tuples vocabs ;
 : explode-tuple ( tuple -- )
     dup tuple-slots swap class "slot-names" word-prop
     [ set ] 2each ;
@@ -138,3 +189,24 @@ SYMBOL: model
     <a f >vocab-link browser-link-href =href a>
         "Browse source" write
     </a> ;
+
+: send-resource ( name -- )
+    template-path get swap path+ resource-path <file-reader>
+    stdio get stream-copy ;
+
+: render-link ( quot name -- )
+    <a swap quot-link =href a> write </a> ;
+
+: session-var ( str -- newstr )
+    request-params session> at ;
+
+: render ( str -- )
+    request-params session> at [ write ] when* ;
+
+: render-error ( str error-str -- )
+    swap validation-errors session> at validation-error? [
+        write
+    ] [
+        drop
+    ] if ;
+

diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor
new file mode 100644 (file)
index 0000000..d253ae1
--- /dev/null
+++ b/extra/furnace/sessions/sessions.factor
@@ -0,0 +1,31 @@
+USING: assocs calendar init kernel math.parser namespaces random ;
+IN: furnace.sessions
+
+SYMBOL: sessions
+
+[ H{ } clone sessions set-global ] "furnace.sessions" add-init-hook
+
+: new-session-id ( -- str )
+    1 big-random number>string ;
+
+TUPLE: session created last-seen user-agent namespace ;
+
+: <session> ( -- obj )
+    now dup H{ } clone
+    [ set-session-created set-session-last-seen set-session-namespace ]
+    \ session construct ;
+
+: new-session ( -- obj id )
+    <session> new-session-id [ sessions get-global set-at ] 2keep ;
+
+: get-session ( id -- obj/f )
+    sessions get-global at* [ "no session found 1" throw ] unless ;
+
+: destroy-session ( id -- )
+    sessions get-global delete-at ;
+
+: session> ( str -- obj )
+    session get session-namespace at ;
+
+: >session ( value key -- )
+    session get session-namespace set-at ;

diff --git a/extra/http/http.factor b/extra/http/http.factor
index f6ea3d699f789865a05fa181854d9401ec0d852d..6ecb3c5a7160a99d5e052cbac522ad14a9a9894c 100644 (file)
--- a/extra/http/http.factor
+++ b/extra/http/http.factor
@@ -60,11 +60,18 @@ IN: http
 : url-decode ( str -- str )
     [ 0 swap url-decode-iter ] "" make ;
 
-: build-url ( path query-params -- str )
+: hash>query ( hash -- str )
+    [ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map
+    "&" join ;
+
+: build-url ( str query-params -- newstr )
     [
-        swap % dup assoc-empty? [
-            "?" % dup
-            [ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map
-            "&" join %
-        ] unless drop
+        over %
+        dup assoc-empty? [
+            2drop
+        ] [
+            CHAR: ? rot member? "&" "?" ? %
+            hash>query %
+        ] if
     ] "" make ;
+    

diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor
index f5adccf445f7f8254136f7b9aefcfc933db020de..ba2fb055e258e014f7c9a32b0faedd974b4411fb 100644 (file)
--- a/extra/sequences/lib/lib.factor
+++ b/extra/sequences/lib/lib.factor
@@ -1,5 +1,6 @@
 USING: combinators.lib kernel sequences math namespaces assocs 
 random sequences.private shuffle math.functions mirrors ;
+USING: arrays math.parser sorting strings ;
 IN: sequences.lib
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -104,3 +105,20 @@ PRIVATE>
 
 : power-set ( seq -- subsets )
     2 over length exact-number-strings swap [ nths ] curry map ;
+
+: cut-find ( seq pred -- before after )
+    dupd find drop dup [ cut ] when ;
+
+: cut3 ( seq pred -- first mid last )
+    [ cut-find ] keep [ not ] compose cut-find ;
+
+: (cut-all) ( seq pred quot -- )
+    [ >r cut3 r> dip >r >r , r> [ , ] when* r> ] 2keep
+    pick [ (cut-all) ] [ 3drop ] if ;
+
+: cut-all ( seq pred quot -- first mid last )
+    [ (cut-all) ] { } make ;
+
+: human-sort ( seq -- newseq )
+    [ dup [ digit? ] [ string>number ] cut-all ] { } map>assoc
+    sort-values keys ;

diff --git a/extra/webapps/help/help.factor b/extra/webapps/help/help.factor
index 145df4119a131329dd69b05d6a5ab87499618acb..28d73607bac3132a935e00eabb9f7d73c94f2562 100644 (file)
--- a/extra/webapps/help/help.factor
+++ b/extra/webapps/help/help.factor
@@ -6,18 +6,19 @@ USING: kernel furnace furnace.validator http.server.responders
        arrays io.files ;
 IN: webapps.help 
 
+! : string>topic ( string -- topic )
+    ! " " split dup length 1 = [ first ] when ;
+
 : show-help ( topic -- )
     serving-html
     dup article-title [
         [ help ] with-html-stream
     ] simple-html-document ;
 
-: string>topic ( string -- topic )
-    " " split dup length 1 = [ first ] when ;
-
 \ show-help {
-    { "topic" "handbook" v-default string>topic }
+    { "topic" }
 } define-action
+\ show-help { { "topic" "handbook" } } default-values
 
 M: link browser-link-href
     link-name
@@ -32,9 +33,10 @@ M: link browser-link-href
     lookup show-help ;
 
 \ show-word {
-    { "word" "call" v-default }
-    { "vocab" "kernel" v-default }
+    { "word" }
+    { "vocab" }
 } define-action
+\ show-word { { "word" "call" } { "vocab" "kernel" } } default-values
 
 M: f browser-link-href
     drop \ f browser-link-href ;
@@ -47,9 +49,11 @@ M: word browser-link-href
     f >vocab-link show-help ;
 
 \ show-vocab {
-    { "vocab" "kernel" v-default }
+    { "vocab" }
 } define-action
 
+\ show-vocab { { "vocab" "kernel" } } default-values
+
 M: vocab-spec browser-link-href
     vocab-name [ show-vocab ] curry quot-link ;
 

diff --git a/extra/webapps/pastebin/annotate-paste.furnace b/extra/webapps/pastebin/annotate-paste.furnace
index abb5cc3d07d49742961ccb4d06237685de555a1a..14a424f77636085a0c79530ed1898f2d1083a8b4 100755 (executable)
--- a/extra/webapps/pastebin/annotate-paste.furnace
+++ b/extra/webapps/pastebin/annotate-paste.furnace
@@ -6,16 +6,16 @@
 
 <table>
 
-<input type="hidden" name="n" value="<% "n" get number>string write %>" />
-
 <tr>
 <th align="right">Summary:</th>
-<td><input type="TEXT" name="summary" value="" /></td>
+<td><input type="TEXT" name="summary" value="<% "summary" render %>" /></td>
+<td align="left" class="error"><% "summary" "*Required" render-error %></td>
 </tr>
 
 <tr>
 <th align="right">Your name:</th>
-<td><input type="TEXT" name="author" value="" /></td>
+<td><input type="TEXT" name="author" value="<% "author" render  %>" /></td>
+<td class="error"><% "author" "*Required" render-error %></td>
 </tr>
 
 <tr>
@@ -23,11 +23,25 @@
 <td><% "modes" render-template %></td>
 </tr>
 
+<!--
+<tr>
+<th align="right">Channel:</th>
+<td><input type="TEXT" name="channel" value="#concatenative" /></td>
+</tr>
+-->
+
+<tr>
+<td></td>
+<td colspan="2" class="error" align="left"><% "contents" "*Required" render-error %></td>
+</tr>
+
 <tr>
 <th align="right" valign="top">Content:</th>
-<td><textarea rows="24" cols="60" name="contents"></textarea></td>
+<td colspan="2"><textarea rows="24" cols="60" name="contents"><% "contents" render %></textarea></td>
 </tr>
 </table>
 
+<input type="hidden" name="n" value="<% "n" get number>string write %>" />
+<input type="hidden" name="furnace-form-submitted" value="annotate-paste"/>
 <input type="SUBMIT" value="Annotate" />
 </form>

diff --git a/extra/webapps/pastebin/modes.furnace b/extra/webapps/pastebin/modes.furnace
index 960b7d4e2735408f2acba5b596842ebd0f16e0c7..18bbec180af5b816e8044fd7805329749a49ea47 100644 (file)
--- a/extra/webapps/pastebin/modes.furnace
+++ b/extra/webapps/pastebin/modes.furnace
@@ -1,7 +1,7 @@
-<% USING: xmode.catalog sequences kernel html.elements assocs io sorting ; %>
+<% USING: furnace xmode.catalog sequences kernel html.elements assocs io sorting continuations ; %>
 
 <select name="mode">
     <% modes keys natural-sort [
-        <option dup "factor" = [ "true" =selected ] when option> write </option>
+        <option dup "mode" session-var = [ "true" =selected ] when option> write </option>
     ] each %>
 </select>

diff --git a/extra/webapps/pastebin/new-paste.furnace b/extra/webapps/pastebin/new-paste.furnace
index 8f48f670d3fa6c8d379673e80458e1a370fd352a..b21e19734d53e05cdfe0b2278b34b59a94973295 100755 (executable)
--- a/extra/webapps/pastebin/new-paste.furnace
+++ b/extra/webapps/pastebin/new-paste.furnace
@@ -1,4 +1,4 @@
-<% USING: furnace namespaces ; %>
+<% USING: continuations furnace namespaces ; %>
 
 <%
     "New paste" "title" set
@@ -11,12 +11,14 @@
 
 <tr>
 <th align="right">Summary:</th>
-<td><input type="TEXT" name="summary" value="" /></td>
+<td><input type="TEXT" name="summary" value="<% "summary" render %>" /></td>
+<td align="left" class="error"><% "summary" "*Required" render-error %></td>
 </tr>
 
 <tr>
 <th align="right">Your name:</th>
-<td><input type="TEXT" name="author" value="" /></td>
+<td><input type="TEXT" name="author" value="<% "author" render  %>" /></td>
+<td class="error"><% "author" "*Required" render-error %></td>
 </tr>
 
 <tr>
@@ -31,12 +33,18 @@
 </tr>
 -->
 
+<tr>
+<td></td>
+<td colspan="2" class="error" align="left"><% "contents" "*Required" render-error %></td>
+</tr>
+
 <tr>
 <th align="right" valign="top">Content:</th>
-<td><textarea rows="24" cols="60" name="contents"></textarea></td>
+<td colspan="2"><textarea rows="24" cols="60" name="contents"><% "contents" render %></textarea></td>
 </tr>
 </table>
 
+<input type="hidden" name="furnace-form-submitted" value="new-paste"/>
 <input type="SUBMIT" value="Submit paste" />
 </form>
 

diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor
index 8e4c0a5be9dc9df6494b00b684a8b4a8d2d28aa4..13d6846aa33e0e68505d9cf6c389138c837df006 100755 (executable)
--- a/extra/webapps/pastebin/pastebin.factor
+++ b/extra/webapps/pastebin/pastebin.factor
@@ -84,28 +84,37 @@ C: <annotation> annotation
         store save-store
     ] keep paste-link permanent-redirect ;
 
+\ new-paste
 \ submit-paste {
-    { "summary" "- no summary -" v-default }
-    { "author" "- no author -" v-default }
-    { "channel" "#concatenative" v-default }
-    { "mode" "factor" v-default }
+    { "summary" v-required }
+    { "author" v-required }
+    { "channel" }
+    { "mode" v-required }
     { "contents" v-required }
-} define-action
+} define-form
+
+\ new-paste {
+    { "channel" "#concatenative" }
+    { "mode" "factor" }
+} default-values
 
 : annotate-paste ( n summary author mode contents -- )
     <annotation> swap get-paste
-    paste-annotations push
-    store save-store ;
+    [ paste-annotations push store save-store ] keep
+    paste-link permanent-redirect ;
 
+[ "n" show-paste ]
 \ annotate-paste {
     { "n" v-required v-number }
-    { "summary" "- no summary -" v-default }
-    { "author" "- no author -" v-default }
-    { "mode" "factor" v-default }
+    { "summary" v-required }
+    { "author" v-required }
+    { "mode" v-required }
     { "contents" v-required }
-} define-action
+} define-form
 
-\ annotate-paste [ "n" show-paste ] define-redirect
+\ show-paste {
+    { "mode" "factor" }
+} default-values
 
 : style.css ( -- )
     "text/css" serving-content

diff --git a/extra/webapps/pastebin/style.css b/extra/webapps/pastebin/style.css
index e3c7c19fc5a7d381378d58216b77f66cade121e2..4a469f92cb0c167d265d616d1a9fbca8003fd0dc 100644 (file)
--- a/extra/webapps/pastebin/style.css
+++ b/extra/webapps/pastebin/style.css
@@ -35,3 +35,7 @@ pre.code {
        border: 1px solid #C1DAD7;
        padding: 10px;
 }
+
+.error {
+       color: red;
+}

diff --git a/misc/factor.sh b/misc/factor.sh
index 11ea2a9cdffc9e4005d12e880902076539ddaf57..12fb45a3e9e54eede1badbb5ec39573ee16215f0 100755 (executable)
--- a/misc/factor.sh
+++ b/misc/factor.sh
@@ -270,7 +270,7 @@ refresh_image() {
 }
 
 install_libraries() {
-       sudo apt-get install libc6-dev libfreetype6-dev wget git-core git-doc libx11-dev glutg3-dev rlwrap
+       sudo apt-get install libc6-dev libfreetype6-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap
 }
 
 case "$1" in