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 756fa13d1c..6d6ce6b4bf 100644 --- 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-form ( word1 word2 hash -- ) + dupd define-action + 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 ) [ @@ -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 -- ) - 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 ; @@ -138,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/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; +}