diff --git a/extra/furnace/authors.txt b/extra/furnace/authors.txt new file mode 100644 index 0000000000..f372b574ae --- /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 85fc6c8727..6a14d40cde 100644 --- 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 c63f107ff7..6d6ce6b4bf 100644 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -1,55 +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 - -SYMBOL: template-path - -: define-authenticated-action ( word params realm -- ) - pick swap "action-realm" set-word-prop - over t "action" set-word-prop - "action-params" set-word-prop ; - -: define-action ( word params -- ) - f define-authenticated-action ; - : code>quotation ( word/quot -- quot ) dup word? [ 1quotation ] when ; -: define-form ( formword actionword params -- ) +SYMBOL: default-action +SYMBOL: template-path + +: 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-form ( word1 word2 hash -- ) dupd define-action - swap code>quotation "form-quotation" set-word-prop ; + swap code>quotation "form-failed" set-word-prop ; -: define-redirect ( word quot -- ) - "action-redirect" set-word-prop ; +: default-values ( word hash -- ) + "default-values" set-word-prop ; -: responder-vocab ( name -- vocab ) - "webapps." swap append ; - -: 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 ; - -: 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 ) [ @@ -59,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 ; @@ -71,62 +83,94 @@ PREDICATE: word action "action" word-prop ; t register-html-callback ] if ; -: render-link ( quot name -- ) - write ; +: 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 ; -: call-action ( params action -- ) - dup "action-realm" word-prop [ - [ (call-action) ] with-basic-authentication - ] [ (call-action) ] if* ; +: page-submitted ( -- ) + [ process-form ] [ request-params session> do-action ] if-form-page ; -: service-request ( params url -- ) - current-action [ +: 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 ; + +: 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 ; + +: 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 ] [ 
 print-error
] recover ] [ "404 no such action: " "argument" get append httpd-error ] if* ; -: service-get ( url -- ) "query" get swap service-request ; +: service-get + "query" get swap service-request ; -: service-post ( url -- ) "response" get swap service-request ; +: service-post + "response" get swap service-request ; -: send-resource ( name -- ) - template-path get swap path+ resource-path - stdio get stream-copy ; - -: render-template ( template -- ) - template-path get swap path+ - ".furnace" append resource-path - run-template-file ; - -: 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 ; @@ -145,3 +189,24 @@ SYMBOL: model vocab-link browser-link-href =href a> "Browse source" write ; + +: send-resource ( name -- ) + template-path get swap path+ resource-path + stdio get stream-copy ; + +: render-link ( quot name -- ) + write ; + +: 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 index 0000000000..d253ae165b --- /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 ; + +: ( -- obj ) + now dup H{ } clone + [ set-session-created set-session-last-seen set-session-namespace ] + \ session construct ; + +: new-session ( -- obj id ) + 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 f6ea3d699f..6ecb3c5a71 100644 --- 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/ui/gadgets/editors/editors.factor b/extra/ui/gadgets/editors/editors.factor index eb1d5daf26..2d447db1e9 100755 --- a/extra/ui/gadgets/editors/editors.factor +++ b/extra/ui/gadgets/editors/editors.factor @@ -34,14 +34,10 @@ focused? ; : field-theme ( gadget -- ) gray swap set-gadget-boundary ; -: construct-editor ( class -- tuple ) - >r { set-gadget-delegate } r> construct +: construct-editor ( object class -- tuple ) + >r { set-gadget-delegate } r> construct dup dup set-editor-self ; inline -TUPLE: source-editor ; - -: source-editor construct-editor ; - : activate-editor-model ( editor model -- ) 2dup add-connection dup activate-model @@ -340,9 +336,6 @@ M: editor gadget-text* editor-string % ; : delete-to-end-of-line T{ one-line-elt } editor-backspace ; editor "general" f { - { T{ key-down f f "RET" } insert-newline } - { T{ key-down f { S+ } "RET" } insert-newline } - { T{ key-down f f "ENTER" } insert-newline } { T{ key-down f f "DELETE" } delete-next-character } { T{ key-down f { S+ } "DELETE" } delete-next-character } { T{ key-down f f "BACKSPACE" } delete-previous-character } @@ -448,6 +441,23 @@ editor "selection" f { { T{ key-down f { S+ C+ } "END" } select-end-of-document } } define-command-map +! Multi-line editors +TUPLE: multiline-editor ; + +: ( -- editor ) + multiline-editor construct-editor ; + +multiline-editor "general" f { + { T{ key-down f f "RET" } insert-newline } + { T{ key-down f { S+ } "RET" } insert-newline } + { T{ key-down f f "ENTER" } insert-newline } +} define-command-map + +TUPLE: source-editor ; + +: ( -- editor ) + source-editor construct-editor ; + ! Fields are like editors except they edit an external model TUPLE: field model editor ; diff --git a/extra/ui/tools/deploy/deploy.factor b/extra/ui/tools/deploy/deploy.factor index e7d9161079..7b20c4591f 100755 --- a/extra/ui/tools/deploy/deploy.factor +++ b/extra/ui/tools/deploy/deploy.factor @@ -95,7 +95,7 @@ deploy-gadget "toolbar" f { { f com-help } { f com-revert } { f com-save } - { T{ key-down f f "RETURN" } com-deploy } + { T{ key-down f f "RET" } com-deploy } } define-command-map : buttons, diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor index b603cc5eea..45494124c8 100755 --- a/extra/ui/tools/interactor/interactor.factor +++ b/extra/ui/tools/interactor/interactor.factor @@ -33,9 +33,8 @@ help ; : ( output -- gadget ) - { set-interactor-output set-gadget-delegate } - interactor construct - dup dup set-editor-self + interactor construct-editor + tuck set-interactor-output dup init-interactor-history dup init-caret-help ; diff --git a/extra/ui/tools/search/search.factor b/extra/ui/tools/search/search.factor index 157e8473ef..f77cf59fad 100755 --- a/extra/ui/tools/search/search.factor +++ b/extra/ui/tools/search/search.factor @@ -33,7 +33,8 @@ M: live-search handle-gesture* ( gadget gesture delegate -- ? ) TUPLE: search-field ; -: ( -- gadget ) search-field construct-editor ; +: ( -- gadget ) + search-field construct-editor ; search-field H{ { T{ key-down f f "UP" } [ find-search-list select-previous ] } diff --git a/extra/webapps/help/help.factor b/extra/webapps/help/help.factor index 145df4119a..28d73607ba 100644 --- 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 abb5cc3d07..14a424f776 100755 --- a/extra/webapps/pastebin/annotate-paste.furnace +++ b/extra/webapps/pastebin/annotate-paste.furnace @@ -6,16 +6,16 @@ -string write %>" /> - - + + - + + @@ -23,11 +23,25 @@ + + + + + + + - +
Summary:" /><% "summary" "*Required" render-error %>
Your name:" /><% "author" "*Required" render-error %>
<% "modes" render-template %>
<% "contents" "*Required" render-error %>
Content:
+string write %>" /> + diff --git a/extra/webapps/pastebin/modes.furnace b/extra/webapps/pastebin/modes.furnace index 960b7d4e27..18bbec180a 100644 --- 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 ; %> diff --git a/extra/webapps/pastebin/new-paste.furnace b/extra/webapps/pastebin/new-paste.furnace index 8f48f670d3..b21e19734d 100755 --- 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 @@ Summary: - +" /> +<% "summary" "*Required" render-error %> Your name: - +" /> +<% "author" "*Required" render-error %> @@ -31,12 +33,18 @@ --> + + +<% "contents" "*Required" render-error %> + + Content: - + + diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor index 8e4c0a5be9..13d6846aa3 100755 --- a/extra/webapps/pastebin/pastebin.factor +++ b/extra/webapps/pastebin/pastebin.factor @@ -84,28 +84,37 @@ C: 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 -- ) 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 e3c7c19fc5..4a469f92cb 100644 --- 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 11ea2a9cdf..12fb45a3e9 100755 --- 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