From 9861146d8d38fdb34ec8005c830c50c25e42cb37 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 4 Jun 2008 19:54:05 -0500 Subject: [PATCH] Implement flash scopes, improved validation and login page, improved http-post --- extra/furnace/actions/actions.factor | 92 ++++++++++++------- extra/furnace/asides/asides.factor | 73 +++++++++++++++ extra/furnace/auth/login/login.factor | 48 +++++++--- extra/furnace/auth/login/login.xml | 13 +++ extra/furnace/flash/flash.factor | 38 ++++++++ extra/furnace/flows/flows.factor | 78 ---------------- extra/furnace/furnace-tests.factor | 7 +- extra/furnace/furnace.factor | 57 ++++++------ extra/furnace/sessions/sessions.factor | 13 +-- extra/html/components/components.factor | 22 +++-- extra/html/templates/chloe/chloe-tests.factor | 20 ++++ extra/html/templates/chloe/chloe.factor | 13 ++- extra/html/templates/chloe/test/test10.xml | 3 + extra/html/templates/chloe/test/test11.xml | 14 +++ extra/http/http-tests.factor | 71 ++++++++++++-- extra/http/http.factor | 72 +++++++++------ extra/http/server/cgi/cgi.factor | 8 +- extra/http/server/server-tests.factor | 4 + extra/http/server/server.factor | 2 +- .../factor-website/factor-website.factor | 6 +- extra/webapps/pastebin/paste.xml | 6 +- extra/webapps/pastebin/pastebin-common.xml | 4 +- extra/webapps/pastebin/pastebin.factor | 14 ++- extra/webapps/planet/planet-common.xml | 4 +- extra/webapps/planet/planet.factor | 5 +- extra/webapps/todo/todo.factor | 3 +- extra/webapps/todo/todo.xml | 4 +- extra/webapps/user-admin/user-admin.factor | 16 +--- extra/webapps/user-admin/user-admin.xml | 4 +- extra/webapps/wiki/changes.xml | 2 +- extra/webapps/wiki/wiki-common.xml | 4 +- extra/webapps/wiki/wiki.factor | 13 ++- extra/xml-rpc/example.factor | 4 +- extra/xml-rpc/xml-rpc.factor | 3 +- 34 files changed, 486 insertions(+), 254 deletions(-) create mode 100644 extra/furnace/asides/asides.factor create mode 100644 extra/furnace/flash/flash.factor delete mode 100644 extra/furnace/flows/flows.factor create mode 100644 extra/html/templates/chloe/test/test10.xml create mode 100644 extra/html/templates/chloe/test/test11.xml create mode 100644 extra/http/server/server-tests.factor diff --git a/extra/furnace/actions/actions.factor b/extra/furnace/actions/actions.factor index 5e237b02a8..7340a532e9 100755 --- a/extra/furnace/actions/actions.factor +++ b/extra/furnace/actions/actions.factor @@ -2,13 +2,15 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors sequences kernel assocs combinators validators http hashtables namespaces fry continuations locals -io arrays math boxes +io arrays math boxes splitting urls xml.entities http.server http.server.responses furnace +furnace.flash html.elements html.components +html.components html.templates.chloe html.templates.chloe.syntax ; IN: furnace.actions @@ -39,48 +41,68 @@ TUPLE: action rest-param init display validate submit ; : ( -- action ) action new-action ; +: flashed-variables ( -- seq ) + { validation-messages named-validation-messages } ; + : handle-get ( action -- response ) - blank-values - [ init>> call ] - [ display>> call ] - bi ; + '[ + , + [ init>> call ] + [ drop flashed-variables restore-flash ] + [ display>> call ] + tri + ] with-exit-continuation ; : validation-failed ( -- * ) - request get method>> "POST" = - [ action get display>> call ] [ <400> ] if exit-with ; + request get method>> "POST" = [ f ] [ <400> ] if exit-with ; -: handle-post ( action -- response ) - init-validation - blank-values - [ validate>> call ] - [ submit>> call ] bi ; - -: handle-rest-param ( arg -- ) - dup length 1 > action get rest-param>> not or - [ <404> exit-with ] [ - action get rest-param>> associate rest-param set - ] if ; - -M: action call-responder* ( path action -- response ) - dup action set - '[ - , dup empty? [ drop ] [ handle-rest-param ] if - - init-validation - , - request get - [ request-params rest-param get assoc-union params set ] - [ method>> ] bi - { - { "GET" [ handle-get ] } - { "HEAD" [ handle-get ] } - { "POST" [ handle-post ] } - } case - ] with-exit-continuation ; +: (handle-post) ( action -- response ) + [ validate>> call ] [ submit>> call ] bi ; : param ( name -- value ) params get at ; +: revalidate-url-key "__u" ; + +: check-url ( url -- ? ) + request get url>> + [ [ protocol>> ] [ host>> ] [ port>> ] tri 3array ] bi@ = ; + +: revalidate-url ( -- url/f ) + revalidate-url-key param dup [ >url dup check-url swap and ] when ; + +: handle-post ( action -- response ) + '[ + form-nesting-key params get at " " split + [ , (handle-post) ] + [ swap '[ , , nest-values ] ] reduce + call + ] with-exit-continuation + [ + revalidate-url + [ flashed-variables ] [ <403> ] if* + ] unless* ; + +: handle-rest-param ( path action -- assoc ) + rest-param>> dup [ associate ] [ 2drop f ] if ; + +: init-action ( path action -- ) + blank-values + init-validation + handle-rest-param + request get request-params assoc-union params set ; + +M: action call-responder* ( path action -- response ) + [ init-action ] keep + request get method>> { + { "GET" [ handle-get ] } + { "HEAD" [ handle-get ] } + { "POST" [ handle-post ] } + } case ; + +M: action modify-form + drop request get url>> revalidate-url-key hidden-form-field ; + : check-validation ( -- ) validation-failed? [ validation-failed ] when ; diff --git a/extra/furnace/asides/asides.factor b/extra/furnace/asides/asides.factor new file mode 100644 index 0000000000..f6b4e2c15f --- /dev/null +++ b/extra/furnace/asides/asides.factor @@ -0,0 +1,73 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors namespaces sequences arrays kernel +assocs assocs.lib hashtables math.parser urls combinators +furnace http http.server http.server.filters furnace.sessions +html.elements html.templates.chloe.syntax ; +IN: furnace.asides + +TUPLE: asides < filter-responder ; + +C: asides + +: begin-aside* ( -- id ) + request get + [ url>> ] [ post-data>> ] [ method>> ] tri 3array + asides sget set-at-unique + session-changed ; + +: end-aside-post ( url post-data -- response ) + request [ + clone + swap >>post-data + swap >>url + ] change + request get url>> path>> split-path + asides get responder>> call-responder ; + +ERROR: end-aside-in-get-error ; + +: end-aside* ( url id -- response ) + request get method>> "POST" = [ end-aside-in-get-error ] unless + asides sget at [ + first3 { + { "GET" [ drop ] } + { "HEAD" [ drop ] } + { "POST" [ end-aside-post ] } + } case + ] [ ] ?if ; + +SYMBOL: aside-id + +: aside-id-key "__a" ; + +: begin-aside ( -- ) + begin-aside* aside-id set ; + +: end-aside ( default -- response ) + aside-id [ f ] change end-aside* ; + +M: asides call-responder* + dup asides set + aside-id-key request get request-params at aside-id set + call-next-method ; + +M: asides init-session* + H{ } clone asides sset + call-next-method ; + +M: asides link-attr ( tag -- ) + drop + "aside" optional-attr { + { "none" [ aside-id off ] } + { "begin" [ begin-aside ] } + { "current" [ ] } + { f [ ] } + } case ; + +M: asides modify-query ( query responder -- query' ) + drop + aside-id get [ aside-id-key associate assoc-union ] when* ; + +M: asides modify-form ( responder -- ) + drop aside-id get aside-id-key hidden-form-field ; diff --git a/extra/furnace/auth/login/login.factor b/extra/furnace/auth/login/login.factor index 58ab47e3e1..d0c4e00953 100755 --- a/extra/furnace/auth/login/login.factor +++ b/extra/furnace/auth/login/login.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors quotations assocs kernel splitting combinators sequences namespaces hashtables sets -fry arrays threads qualified random validators +fry arrays threads qualified random validators words io io.sockets io.encodings.utf8 @@ -26,14 +26,29 @@ furnace.auth furnace.auth.providers furnace.auth.providers.db furnace.actions -furnace.flows +furnace.asides +furnace.flash furnace.sessions furnace.boilerplate ; QUALIFIED: smtp IN: furnace.auth.login +: word>string ( word -- string ) + [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ; + +: words>strings ( seq -- seq' ) + [ word>string ] map ; + +: string>word ( string -- word ) + ":" split1 swap lookup ; + +: strings>words ( seq -- seq' ) + [ string>word ] map ; + TUPLE: login < dispatcher users checksum ; +TUPLE: protected < filter-responder description capabilities ; + : users ( -- provider ) login get users>> ; @@ -64,7 +79,7 @@ M: user-saver dispose ! ! ! Login : successful-login ( user -- response ) - username>> set-uid URL" $login" end-flow ; + username>> set-uid URL" $login" end-aside ; : login-failed ( -- * ) "invalid username or password" validation-error @@ -72,6 +87,13 @@ M: user-saver dispose : ( -- action ) + [ + protected fget [ + [ description>> "description" set-value ] + [ capabilities>> words>strings "capabilities" set-value ] bi + ] when* + ] >>init + { login "login" } >>template [ @@ -177,7 +199,7 @@ M: user-saver dispose drop - URL" $login" end-flow + URL" $login" end-aside ] >>submit ; ! ! ! Password recovery @@ -290,23 +312,23 @@ SYMBOL: lost-password-from [ f set-uid - URL" $login" end-flow + URL" $login" end-aside ] >>submit ; ! ! ! Authentication logic - -TUPLE: protected < filter-responder capabilities ; - -C: protected +: ( responder -- protected ) + protected new + swap >>responder ; : show-login-page ( -- response ) - begin-flow - URL" $login/login" ; + begin-aside + URL" $login/login" { protected } ; : check-capabilities ( responder user -- ? ) [ capabilities>> ] bi@ subset? ; M: protected call-responder* ( path responder -- response ) + dup protected set uid dup [ users get-user 2dup check-capabilities [ [ logged-in-user set ] [ save-user-after ] bi @@ -337,7 +359,9 @@ M: login call-responder* ( path responder -- response ) ! ! ! Configuration : allow-edit-profile ( login -- login ) - f + + "edit your profile" >>description + "edit-profile" add-responder ; : allow-registration ( login -- login ) diff --git a/extra/furnace/auth/login/login.xml b/extra/furnace/auth/login/login.xml index a52aed59d7..a7ac92bf44 100644 --- a/extra/furnace/auth/login/login.xml +++ b/extra/furnace/auth/login/login.xml @@ -4,6 +4,19 @@ Login + +

You must log in to .

+ + + +

Your user must have the following capabilities:

+
    + +
    • +     +
+ + diff --git a/extra/furnace/flash/flash.factor b/extra/furnace/flash/flash.factor new file mode 100644 index 0000000000..21fd20ccb4 --- /dev/null +++ b/extra/furnace/flash/flash.factor @@ -0,0 +1,38 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces assocs assocs.lib kernel sequences urls +http http.server http.server.filters http.server.redirection +furnace furnace.sessions ; +IN: furnace.flash + +: flash-id-key "__f" ; + +TUPLE: flash-scopes < filter-responder ; + +C: flash-scopes + +SYMBOL: flash-scope + +: fget ( key -- value ) flash-scope get at ; + +M: flash-scopes call-responder* + flash-id-key + request get request-params at + flash-scopes sget at flash-scope set + call-next-method ; + +M: flash-scopes init-session* + H{ } clone flash-scopes sset + call-next-method ; + +: make-flash-scope ( seq -- id ) + [ dup get ] H{ } map>assoc flash-scopes sget set-at-unique + session-changed ; + +: ( url seq -- response ) + make-flash-scope + [ clone ] dip flash-id-key set-query-param + ; + +: restore-flash ( seq -- ) + [ flash-scope get key? ] filter [ [ fget ] keep set ] each ; diff --git a/extra/furnace/flows/flows.factor b/extra/furnace/flows/flows.factor deleted file mode 100644 index eb98c1a26b..0000000000 --- a/extra/furnace/flows/flows.factor +++ /dev/null @@ -1,78 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors namespaces sequences arrays kernel -assocs assocs.lib hashtables math.parser urls combinators -furnace http http.server http.server.filters furnace.sessions -html.elements html.templates.chloe.syntax ; -IN: furnace.flows - -TUPLE: flows < filter-responder ; - -C: flows - -: begin-flow* ( -- id ) - request get - [ url>> ] [ post-data>> ] [ method>> ] tri 3array - flows sget set-at-unique - session-changed ; - -: end-flow-post ( url post-data -- response ) - request [ - clone - "POST" >>method - swap >>post-data - swap >>url - ] change - request get url>> path>> split-path - flows get responder>> call-responder ; - -: end-flow* ( url id -- response ) - flows sget at [ - first3 { - { "GET" [ drop ] } - { "HEAD" [ drop ] } - { "POST" [ end-flow-post ] } - } case - ] [ ] ?if ; - -SYMBOL: flow-id - -: flow-id-key "factorflowid" ; - -: begin-flow ( -- ) - begin-flow* flow-id set ; - -: end-flow ( default -- response ) - flow-id get end-flow* ; - -M: flows call-responder* - dup flows set - flow-id-key request get request-params at flow-id set - call-next-method ; - -M: flows init-session* - H{ } clone flows sset - call-next-method ; - -M: flows link-attr ( tag -- ) - drop - "flow" optional-attr { - { "none" [ flow-id off ] } - { "begin" [ begin-flow ] } - { "current" [ ] } - { f [ ] } - } case ; - -M: flows modify-query ( query responder -- query' ) - drop - flow-id get [ flow-id-key associate assoc-union ] when* ; - -M: flows hidden-form-field ( responder -- ) - drop - flow-id get [ - - ] when* ; diff --git a/extra/furnace/furnace-tests.factor b/extra/furnace/furnace-tests.factor index 5cf2dad9ad..f07fe620d8 100644 --- a/extra/furnace/furnace-tests.factor +++ b/extra/furnace/furnace-tests.factor @@ -1,6 +1,7 @@ IN: furnace.tests USING: http.server.dispatchers http.server.responses -http.server furnace tools.test kernel namespaces accessors ; +http.server furnace tools.test kernel namespaces accessors +io.streams.string ; TUPLE: funny-dispatcher < dispatcher ; : funny-dispatcher new-dispatcher ; @@ -28,3 +29,7 @@ M: base-path-check-responder call-responder* V{ } responder-nesting set "a/b/c" split-path main-responder get call-responder body>> ] unit-test + +[ "" ] +[ [ "&&&" "foo" hidden-form-field ] with-string-writer ] +unit-test diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index 370c4f84a3..f61ec5ff40 100644 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -6,6 +6,7 @@ vocabs.loader classes fry urls multiline xml xml.data +xml.entities xml.writer xml.utilities html.components @@ -64,15 +65,19 @@ M: object modify-query drop ; { "POST" [ ] } } case ; -GENERIC: hidden-form-field ( responder -- ) +GENERIC: modify-form ( responder -- ) -M: object hidden-form-field drop ; +M: object modify-form drop ; : request-params ( request -- assoc ) dup method>> { { "GET" [ url>> query>> ] } { "HEAD" [ url>> query>> ] } - { "POST" [ post-data>> ] } + { "POST" [ + post-data>> + dup content-type>> "application/x-www-form-urlencoded" = + [ content>> ] [ drop f ] if + ] } } case ; SYMBOL: exit-continuation @@ -128,20 +133,34 @@ CHLOE: a [ drop ] tri ; +: hidden-form-field ( value name -- ) + over [ + string =value + input/> + ] [ 2drop ] if ; + +: form-nesting-key "factorformnesting" ; + +: form-magic ( tag -- ) + [ modify-form ] each-responder + nested-values get " " join f like form-nesting-key hidden-form-field + "for" optional-attr [ hidden render ] when* ; + : form-start-tag ( tag -- ) [ [
- ] [ - [ hidden-form-field ] each-responder - "for" optional-attr [ hidden render ] when* - ] bi + ] + [ form-magic ] bi ] with-scope ; CHLOE: form @@ -167,17 +186,3 @@ CHLOE: button [ [ children>string 1array ] dip "button" tag-named set-tag-children ] [ nip ] } 2cleave process-chloe-tag ; - -: attr>word ( value -- word/f ) - dup ":" split1 swap lookup - [ ] [ "No such word: " swap append throw ] ?if ; - -: attr>var ( value -- word/f ) - attr>word dup symbol? [ - "Must be a symbol: " swap append throw - ] unless ; - -: if-satisfied? ( tag -- ? ) - "code" required-attr attr>word execute ; - -CHLOE: if dup if-satisfied? [ process-tag-children ] [ drop ] if ; diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor index 5ea389c87e..16fefe42fc 100755 --- a/extra/furnace/sessions/sessions.factor +++ b/extra/furnace/sessions/sessions.factor @@ -109,14 +109,14 @@ M: session-saver dispose [ session set ] [ save-session-after ] bi sessions get responder>> call-responder ; -: session-id-key "factorsessid" ; +: session-id-key "__s" ; : cookie-session-id ( request -- id/f ) session-id-key get-cookie dup [ value>> string>number ] when ; : post-session-id ( request -- id/f ) - session-id-key swap post-data>> at string>number ; + session-id-key swap request-params at string>number ; : request-session-id ( -- id/f ) request get dup method>> { @@ -137,13 +137,8 @@ M: session-saver dispose : put-session-cookie ( response -- response' ) session get id>> number>string put-cookie ; -M: sessions hidden-form-field ( responder -- ) - drop - > number>string =value - input/> ; +M: sessions modify-form ( responder -- ) + drop session get id>> session-id-key hidden-form-field ; M: sessions call-responder* ( path responder -- response ) sessions set diff --git a/extra/html/components/components.factor b/extra/html/components/components.factor index c013007a14..90a00ed4ef 100644 --- a/extra/html/components/components.factor +++ b/extra/html/components/components.factor @@ -29,22 +29,30 @@ SYMBOL: values : deposit-slots ( destination names -- ) [ ] dip deposit-values ; -: with-each-index ( seq quot -- ) - '[ +: with-each-index ( name quot -- ) + [ value ] dip '[ [ - values [ clone ] change + blank-values 1+ "index" set-value @ ] with-scope ] each-index ; inline -: with-each-value ( seq quot -- ) +: with-each-value ( name quot -- ) '[ "value" set-value @ ] with-each-index ; inline -: with-each-object ( seq quot -- ) +: with-each-object ( name quot -- ) '[ from-object @ ] with-each-index ; inline -: with-values ( object quot -- ) - '[ blank-values , from-object @ ] with-scope ; inline +SYMBOL: nested-values + +: with-values ( name quot -- ) + '[ + , + [ nested-values [ swap prefix ] change ] + [ value blank-values from-object ] + bi + @ + ] with-scope ; inline : nest-values ( name quot -- ) swap [ diff --git a/extra/html/templates/chloe/chloe-tests.factor b/extra/html/templates/chloe/chloe-tests.factor index d4c02061b2..e50f65141e 100644 --- a/extra/html/templates/chloe/chloe-tests.factor +++ b/extra/html/templates/chloe/chloe-tests.factor @@ -148,3 +148,23 @@ TUPLE: person first-name last-name ; "test9" test-template call-template ] run-template ] unit-test + +[ ] [ H{ { "a" H{ { "b" "c" } } } } values set ] unit-test + +[ "" ] [ + [ + "test10" test-template call-template + ] run-template +] unit-test + +[ ] [ blank-values ] unit-test + +[ ] [ + H{ { "first-name" "RBaxter" } { "last-name" "Unknown" } } "person" set-value +] unit-test + +[ "
RBaxterUnknown
" ] [ + [ + "test11" test-template call-template + ] run-template [ blank? not ] filter +] unit-test diff --git a/extra/html/templates/chloe/chloe.factor b/extra/html/templates/chloe/chloe.factor index 9e0aa3fe1d..cb56bd71ce 100644 --- a/extra/html/templates/chloe/chloe.factor +++ b/extra/html/templates/chloe/chloe.factor @@ -68,7 +68,7 @@ CHLOE: odd "index" value odd? [ process-tag-children ] [ drop ] if ; : (bind-tag) ( tag quot -- ) [ - [ "name" required-attr value ] keep + [ "name" required-attr ] keep '[ , process-tag-children ] ] dip call ; inline @@ -85,6 +85,17 @@ CHLOE: comment drop ; CHLOE: call-next-template drop call-next-template ; +: attr>word ( value -- word/f ) + dup ":" split1 swap lookup + [ ] [ "No such word: " swap append throw ] ?if ; + +: if-satisfied? ( tag -- ? ) + [ "code" optional-attr [ attr>word execute ] [ t ] if* ] + [ "value" optional-attr [ value ] [ t ] if* ] + bi and ; + +CHLOE: if dup if-satisfied? [ process-tag-children ] [ drop ] if ; + CHLOE-SINGLETON: label CHLOE-SINGLETON: link CHLOE-SINGLETON: farkup diff --git a/extra/html/templates/chloe/test/test10.xml b/extra/html/templates/chloe/test/test10.xml new file mode 100644 index 0000000000..33fe2008a5 --- /dev/null +++ b/extra/html/templates/chloe/test/test10.xml @@ -0,0 +1,3 @@ + + + diff --git a/extra/html/templates/chloe/test/test11.xml b/extra/html/templates/chloe/test/test11.xml new file mode 100644 index 0000000000..f74256bd84 --- /dev/null +++ b/extra/html/templates/chloe/test/test11.xml @@ -0,0 +1,14 @@ + + + + + + + + + + + +
+ + diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 471d7e276b..c1d5b46aa4 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -1,15 +1,16 @@ USING: http tools.test multiline tuple-syntax io.streams.string kernel arrays splitting sequences -assocs io.sockets db db.sqlite continuations urls ; +assocs io.sockets db db.sqlite continuations urls hashtables ; IN: http.tests : lf>crlf "\n" split "\r\n" join ; STRING: read-request-test-1 -GET http://foo/bar HTTP/1.1 +POST http://foo/bar HTTP/1.1 Some-Header: 1 Some-Header: 2 Content-Length: 4 +Content-type: application/octet-stream blah ; @@ -17,10 +18,10 @@ blah [ TUPLE{ request url: TUPLE{ url protocol: "http" port: 80 path: "/bar" } - method: "GET" + method: "POST" version: "1.1" - header: H{ { "some-header" "1; 2" } { "content-length" "4" } } - post-data: "blah" + header: H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } } + post-data: TUPLE{ post-data content: "blah" raw: "blah" content-type: "application/octet-stream" } cookies: V{ } } ] [ @@ -30,8 +31,9 @@ blah ] unit-test STRING: read-request-test-1' -GET /bar HTTP/1.1 +POST /bar HTTP/1.1 content-length: 4 +content-type: application/octet-stream some-header: 1; 2 blah @@ -87,7 +89,7 @@ blah code: 404 message: "not found" header: H{ { "content-type" "text/html; charset=UTF8" } } - cookies: V{ } + cookies: { } content-type: "text/html" content-charset: "UTF8" } @@ -172,7 +174,7 @@ test-db [ [ ] [ [ - f + "" add-responder @@ -219,3 +221,56 @@ test-db [ [ "Hi" ] [ "http://localhost:1237/" http-get ] unit-test [ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test + +USING: html.components html.elements xml xml.utilities validators +furnace furnace.flash ; + +SYMBOL: a + +[ ] [ + [ + + + [ a get-global "a" set-value ] >>init + [ [ "a" render ] "text/html" ] >>display + [ { { "a" [ v-integer ] } } validate-params ] >>validate + [ "a" value a set-global URL" " ] >>submit + + + >>default + add-quit-action + test-db + main-responder set + + [ 1237 httpd ] "HTTPD test" spawn drop + ] with-scope +] unit-test + +[ ] [ 100 sleep ] unit-test + +3 a set-global + +: test-a string>xml "input" tag-named "value" swap at ; + +[ "3" ] [ + "http://localhost:1237/" http-get* + swap dup cookies>> "cookies" set session-id-key get-cookie + value>> "session-id" set test-a +] unit-test + +[ "4" ] [ + H{ { "a" "4" } { "__u" "http://localhost:1237/" } } "session-id" get session-id-key associate assoc-union + "http://localhost:1237/" "cookies" get >>cookies http-request nip test-a +] unit-test + +[ 4 ] [ a get-global ] unit-test + +! Test flash scope +[ "xyz" ] [ + H{ { "a" "xyz" } { "__u" "http://localhost:1237/" } } "session-id" get session-id-key associate assoc-union + "http://localhost:1237/" "cookies" get >>cookies http-request nip test-a +] unit-test + +[ 4 ] [ a get-global ] unit-test + +[ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test diff --git a/extra/http/http.factor b/extra/http/http.factor index e8f7189f75..7499796b77 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -10,7 +10,7 @@ io io.server io.sockets.secure unicode.case unicode.categories qualified -urls html.templates ; +urls html.templates xml xml.data xml.writer ; EXCLUDE: fry => , ; @@ -132,7 +132,6 @@ url version header post-data -post-data-type cookies ; : set-header ( request/response value key -- request/response ) @@ -177,19 +176,27 @@ cookies ; : header ( request/response key -- value ) swap header>> at ; -SYMBOL: max-post-request +TUPLE: post-data raw content content-type ; -1024 256 * max-post-request set-global +: ( raw content-type -- post-data ) + post-data new + swap >>content-type + swap >>raw ; -: content-length ( header -- n ) - "content-length" swap at string>number dup [ - dup max-post-request get > [ - "content-length > max-post-request" throw - ] when - ] when ; +: parse-post-data ( post-data -- post-data ) + [ ] [ raw>> ] [ content-type>> ] tri { + { "application/x-www-form-urlencoded" [ query>assoc ] } + { "text/xml" [ string>xml ] } + [ drop ] + } case >>content ; : read-post-data ( request -- request ) - dup header>> content-length [ read >>post-data ] when* ; + dup method>> "POST" = [ + [ ] + [ "content-length" header string>number read ] + [ "content-type" header ] tri + parse-post-data >>post-data + ] when ; : extract-host ( request -- request ) [ ] [ url>> ] [ "host" header parse-host ] tri @@ -197,13 +204,6 @@ SYMBOL: max-post-request ensure-port drop ; -: extract-post-data-type ( request -- request ) - dup "content-type" header >>post-data-type ; - -: parse-post-data ( request -- request ) - dup post-data-type>> "application/x-www-form-urlencoded" = - [ dup post-data>> query>assoc >>post-data ] when ; - : extract-cookies ( request -- request ) dup "cookie" header [ parse-cookies >>cookies ] when* ; @@ -225,8 +225,6 @@ SYMBOL: max-post-request read-post-data detect-protocol extract-host - extract-post-data-type - parse-post-data extract-cookies ; : write-method ( request -- request ) @@ -238,12 +236,6 @@ SYMBOL: max-post-request : write-version ( request -- request ) "HTTP/" write dup request-version write crlf ; -: unparse-post-data ( request -- request ) - dup post-data>> dup sequence? [ drop ] [ - assoc>query >>post-data - "application/x-www-form-urlencoded" >>post-data-type - ] if ; - : url-host ( url -- string ) [ host>> ] [ port>> ] bi dup "http" protocol-port = [ drop ] [ ":" swap number>string 3append ] if ; @@ -251,13 +243,33 @@ SYMBOL: max-post-request : write-request-header ( request -- request ) dup header>> >hashtable over url>> host>> [ over url>> url-host "host" pick set-at ] when - over post-data>> [ length "content-length" pick set-at ] when* - over post-data-type>> [ "content-type" pick set-at ] when* + over post-data>> [ + [ raw>> length "content-length" pick set-at ] + [ content-type>> "content-type" pick set-at ] + bi + ] when* over cookies>> f like [ unparse-cookies "cookie" pick set-at ] when* write-header ; +GENERIC: >post-data ( object -- post-data ) + +M: post-data >post-data ; + +M: string >post-data "application/octet-stream" ; + +M: byte-array >post-data "application/octet-stream" ; + +M: xml >post-data xml>string "text/xml" ; + +M: assoc >post-data assoc>query "application/x-www-form-urlencoded" ; + +M: f >post-data ; + +: unparse-post-data ( request -- request ) + [ >post-data ] change-post-data ; + : write-post-data ( request -- request ) - dup post-data>> [ write ] when* ; + dup method>> "POST" = [ dup post-data>> raw>> write ] when ; : write-request ( request -- ) unparse-post-data @@ -307,7 +319,7 @@ body ; : read-response-header read-header >>header - extract-cookies + dup "set-cookie" header parse-cookies >>cookies dup "content-type" header [ parse-content-type [ >>content-type ] [ >>content-charset ] bi* ] when* ; diff --git a/extra/http/server/cgi/cgi.factor b/extra/http/server/cgi/cgi.factor index cf8a35f141..a6d8948790 100755 --- a/extra/http/server/cgi/cgi.factor +++ b/extra/http/server/cgi/cgi.factor @@ -35,8 +35,10 @@ IN: http.server.cgi request get "accept" header "HTTP_ACCEPT" set post? [ - request get post-data-type>> "CONTENT_TYPE" set - request get post-data>> length number>string "CONTENT_LENGTH" set + request get post-data>> raw>> + [ "CONTENT_TYPE" set ] + [ length number>string "CONTENT_LENGTH" set ] + bi ] when ] H{ } make-assoc ; @@ -51,7 +53,7 @@ IN: http.server.cgi "CGI output follows" >>message swap '[ , output-stream get swap [ - post? [ request get post-data>> write flush ] when + post? [ request get post-data>> raw>> write flush ] when input-stream get swap (stream-copy) ] with-stream ] >>body ; diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor new file mode 100644 index 0000000000..c29912b8c7 --- /dev/null +++ b/extra/http/server/server-tests.factor @@ -0,0 +1,4 @@ +USING: http http.server math sequences continuations tools.test ; +IN: http.server.tests + +[ t ] [ [ \ + first ] [ <500> ] recover response? ] unit-test diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 756a0de0ff..10d6070f7b 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -40,7 +40,7 @@ main-responder global [ <404> or ] change-at : <500> ( error -- response ) 500 "Internal server error" - development-mode get [ swap '[ , http-error. ] >>body ] [ drop ] if ; + swap development-mode get [ '[ , http-error. ] >>body ] [ drop ] if ; : do-response ( response -- ) dup write-response diff --git a/extra/webapps/factor-website/factor-website.factor b/extra/webapps/factor-website/factor-website.factor index 853af6e845..cd6dde255c 100644 --- a/extra/webapps/factor-website/factor-website.factor +++ b/extra/webapps/factor-website/factor-website.factor @@ -6,7 +6,8 @@ namespaces db db.sqlite smtp http.server http.server.dispatchers furnace.db -furnace.flows +furnace.asides +furnace.flash furnace.sessions furnace.auth.login furnace.auth.providers.db @@ -53,8 +54,7 @@ TUPLE: factor-website < dispatcher ; allow-edit-profile { factor-website "page" } >>template - - + test-db ; : init-factor-website ( -- ) diff --git a/extra/webapps/pastebin/paste.xml b/extra/webapps/pastebin/paste.xml index 9f35d83fd8..453f7b590b 100644 --- a/extra/webapps/pastebin/paste.xml +++ b/extra/webapps/pastebin/paste.xml @@ -28,7 +28,7 @@
- Delete Annotation + Delete Annotation @@ -36,13 +36,13 @@

New Annotation

- + - + diff --git a/extra/webapps/pastebin/pastebin-common.xml b/extra/webapps/pastebin/pastebin-common.xml index 5ef44ad6ce..a27a1290dd 100644 --- a/extra/webapps/pastebin/pastebin-common.xml +++ b/extra/webapps/pastebin/pastebin-common.xml @@ -14,10 +14,10 @@ - | Edit Profile + | Edit Profile - | Logout + | Logout diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor index 69650b4d73..06cdd5adf0 100644 --- a/extra/webapps/pastebin/pastebin.factor +++ b/extra/webapps/pastebin/pastebin.factor @@ -132,7 +132,7 @@ M: annotation entity-link "id" value "new-annotation" [ - "id" set-value + "parent" set-value mode-names "modes" set-value "factor" "mode" set-value ] nest-values @@ -212,12 +212,12 @@ M: annotation entity-link ] >>display [ - { { "id" [ v-integer ] } } validate-params + { { "parent" [ v-integer ] } } validate-params validate-entity ] >>validate [ - "id" value f + "parent" value f [ deposit-entity-slots ] [ insert-tuple ] [ entity-link ] @@ -246,9 +246,13 @@ can-delete-pastes? define-capability "paste" add-responder "paste.atom" add-responder "new-paste" add-responder - { can-delete-pastes? } "delete-paste" add-responder + + "delete pastes" >>description + { can-delete-pastes? } >>capabilities "delete-paste" add-responder "new-annotation" add-responder - { can-delete-pastes? } "delete-annotation" add-responder + + "delete annotations" >>description + { can-delete-pastes? } >>capabilities "delete-annotation" add-responder { pastebin "pastebin-common" } >>template ; diff --git a/extra/webapps/planet/planet-common.xml b/extra/webapps/planet/planet-common.xml index e92f88c2c2..34ee73da67 100644 --- a/extra/webapps/planet/planet-common.xml +++ b/extra/webapps/planet/planet-common.xml @@ -11,10 +11,10 @@ - | Edit Profile + | Edit Profile - | Logout + | Logout diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index c5fa5e25d4..3c0e2ad267 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -198,7 +198,10 @@ can-administer-planet-factor? define-capability planet-factor new-dispatcher "list" add-main-responder "feed.xml" add-responder - { can-administer-planet-factor? } "admin" add-responder + + "administer Planet Factor" >>description + { can-administer-planet-factor? } >>capabilities + "admin" add-responder { planet-factor "planet-common" } >>template ; diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor index 3600e2f874..1cecbc1094 100755 --- a/extra/webapps/todo/todo.factor +++ b/extra/webapps/todo/todo.factor @@ -122,4 +122,5 @@ todo "TODO" "delete" add-responder { todo-list "todo" } >>template - f ; + + "view your todo list" >>description ; diff --git a/extra/webapps/todo/todo.xml b/extra/webapps/todo/todo.xml index 3dd0b9a7d1..e087fbfcfc 100644 --- a/extra/webapps/todo/todo.xml +++ b/extra/webapps/todo/todo.xml @@ -9,10 +9,10 @@ | Add Item - | Edit Profile + | Edit Profile - | Logout + | Logout

diff --git a/extra/webapps/user-admin/user-admin.factor b/extra/webapps/user-admin/user-admin.factor index b8687274f0..78c972fa34 100644 --- a/extra/webapps/user-admin/user-admin.factor +++ b/extra/webapps/user-admin/user-admin.factor @@ -18,18 +18,6 @@ IN: webapps.user-admin TUPLE: user-admin < dispatcher ; -: word>string ( word -- string ) - [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ; - -: words>strings ( seq -- seq' ) - [ word>string ] map ; - -: string>word ( string -- word ) - ":" split1 swap lookup ; - -: strings>words ( seq -- seq' ) - [ string>word ] map ; - : ( -- action ) [ f select-tuples "users" set-value ] >>init @@ -156,7 +144,9 @@ can-administer-users? define-capability "delete" add-responder { user-admin "user-admin" } >>template - { can-administer-users? } ; + + "administer users" >>description + { can-administer-users? } >>capabilities ; : make-admin ( username -- ) diff --git a/extra/webapps/user-admin/user-admin.xml b/extra/webapps/user-admin/user-admin.xml index 93a701a696..9cb9ef0a0a 100644 --- a/extra/webapps/user-admin/user-admin.xml +++ b/extra/webapps/user-admin/user-admin.xml @@ -7,10 +7,10 @@ | Add User - | Edit Profile + | Edit Profile - | Logout + | Logout

diff --git a/extra/webapps/wiki/changes.xml b/extra/webapps/wiki/changes.xml index 95fb0de2fe..5b3e9de2c4 100644 --- a/extra/webapps/wiki/changes.xml +++ b/extra/webapps/wiki/changes.xml @@ -7,7 +7,7 @@
  • - + on by diff --git a/extra/webapps/wiki/wiki-common.xml b/extra/webapps/wiki/wiki-common.xml index 67a5b91c93..c3d203cd2e 100644 --- a/extra/webapps/wiki/wiki-common.xml +++ b/extra/webapps/wiki/wiki-common.xml @@ -13,10 +13,10 @@ - | Edit Profile + | Edit Profile - | Logout + | Logout diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index 6dcf89e208..dd2e1291f9 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -214,6 +214,10 @@ revision "REVISIONS" { { wiki "user-edits" } >>template ; +SYMBOL: can-delete-wiki-articles? + +can-delete-wiki-articles? define-capability + : ( -- dispatcher ) wiki new-dispatcher @@ -222,7 +226,9 @@ revision "REVISIONS" { "revision" add-responder "revisions" add-responder "diff" add-responder - { } "edit" add-responder + + "edit wiki articles" >>description + "edit" add-responder { wiki "page-common" } >>template >>default @@ -230,6 +236,9 @@ revision "REVISIONS" { "user-edits" add-responder "articles" add-responder "changes" add-responder - { } "delete" add-responder + + "delete wiki articles" >>description + { can-delete-wiki-articles? } >>capabilities + "delete" add-responder { wiki "wiki-common" } >>template ; diff --git a/extra/xml-rpc/example.factor b/extra/xml-rpc/example.factor index 0223dfde69..836a85d52d 100644 --- a/extra/xml-rpc/example.factor +++ b/extra/xml-rpc/example.factor @@ -22,6 +22,6 @@ USING: kernel hashtables xml-rpc xml calendar sequences put-http-response ; : test-rpc-arith - "add" { 1 2 } send-rpc xml>string - "text/xml" swap "http://localhost:8080/responder/rpc/" + "add" { 1 2 } send-rpc + "http://localhost:8080/responder/rpc/" http-post ; diff --git a/extra/xml-rpc/xml-rpc.factor b/extra/xml-rpc/xml-rpc.factor index d41f66739c..4b96d13316 100755 --- a/extra/xml-rpc/xml-rpc.factor +++ b/extra/xml-rpc/xml-rpc.factor @@ -158,8 +158,7 @@ TAG: array xml>item : post-rpc ( rpc url -- rpc ) ! This needs to do something in the event of an error - >r "text/xml" swap send-rpc xml>string r> http-post - 2nip string>xml receive-rpc ; + >r send-rpc r> http-post nip string>xml receive-rpc ; : invoke-method ( params method url -- ) >r swap r> post-rpc ;
Summary:
Author:
Mode:
Body:
Body:
Captcha: