From 99b23348a8cab1c0c3ab4d70c5204257b374be79 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 5 Jun 2008 00:18:36 -0500 Subject: [PATCH] Various furnace improvements; add present vocabulary for converting objects to human-readable strings --- extra/furnace/actions/actions-tests.factor | 18 +++++++ extra/furnace/actions/actions.factor | 10 ++-- extra/furnace/furnace-tests.factor | 2 +- extra/furnace/furnace.factor | 14 ++++-- extra/html/components/components-tests.factor | 2 - extra/html/components/components.factor | 48 ++++++++++++------- extra/html/elements/elements.factor | 15 +----- extra/html/templates/chloe/chloe-tests.factor | 14 +++++- extra/html/templates/chloe/chloe.factor | 4 +- extra/html/templates/chloe/test/test12.xml | 3 ++ extra/http/http.factor | 10 ++-- .../server/dispatchers/dispatchers.factor | 9 ++-- .../redirection/redirection-tests.factor | 18 +++---- extra/present/present.factor | 15 ++++++ extra/rss/rss.factor | 6 +-- extra/urls/urls-tests.factor | 6 ++- extra/urls/urls.factor | 34 +++++++++---- 17 files changed, 149 insertions(+), 79 deletions(-) create mode 100644 extra/html/templates/chloe/test/test12.xml create mode 100644 extra/present/present.factor diff --git a/extra/furnace/actions/actions-tests.factor b/extra/furnace/actions/actions-tests.factor index 8aa0f92b97..60a526fb24 100755 --- a/extra/furnace/actions/actions-tests.factor +++ b/extra/furnace/actions/actions-tests.factor @@ -21,3 +21,21 @@ blah init-request { } "action-1" get call-responder ] unit-test + + + "a" >>rest + [ "a" param string>number sq ] >>display +"action-2" set + +STRING: action-request-test-2 +GET http://foo/bar/123 HTTP/1.1 + +blah +; + +[ 25 ] [ + action-request-test-2 lf>crlf + [ read-request ] with-string-reader + init-request + { "5" } "action-2" get call-responder +] unit-test diff --git a/extra/furnace/actions/actions.factor b/extra/furnace/actions/actions.factor index 7340a532e9..1cef8e24e5 100755 --- a/extra/furnace/actions/actions.factor +++ b/extra/furnace/actions/actions.factor @@ -17,7 +17,7 @@ IN: furnace.actions SYMBOL: params -SYMBOL: rest-param +SYMBOL: rest : render-validation-messages ( -- ) validation-messages get @@ -29,7 +29,7 @@ SYMBOL: rest-param CHLOE: validation-messages drop render-validation-messages ; -TUPLE: action rest-param init display validate submit ; +TUPLE: action rest init display validate submit ; : new-action ( class -- action ) new @@ -83,13 +83,13 @@ TUPLE: action rest-param init display validate submit ; [ flashed-variables ] [ <403> ] if* ] unless* ; -: handle-rest-param ( path action -- assoc ) - rest-param>> dup [ associate ] [ 2drop f ] if ; +: handle-rest ( path action -- assoc ) + rest>> dup [ [ "/" join ] dip associate ] [ 2drop f ] if ; : init-action ( path action -- ) blank-values init-validation - handle-rest-param + handle-rest request get request-params assoc-union params set ; M: action call-responder* ( path action -- response ) diff --git a/extra/furnace/furnace-tests.factor b/extra/furnace/furnace-tests.factor index f07fe620d8..223b20455d 100644 --- a/extra/furnace/furnace-tests.factor +++ b/extra/furnace/furnace-tests.factor @@ -30,6 +30,6 @@ M: base-path-check-responder call-responder* "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 f61ec5ff40..4859d8b0f6 100644 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays kernel combinators assocs continuations namespaces sequences splitting words -vocabs.loader classes -fry urls multiline +vocabs.loader classes strings +fry urls multiline present xml xml.data xml.entities @@ -52,12 +52,16 @@ GENERIC: modify-query ( query responder -- query' ) M: object modify-query drop ; -: adjust-url ( url -- url' ) +GENERIC: adjust-url ( url -- url' ) + +M: url adjust-url clone [ [ modify-query ] each-responder ] change-query [ resolve-base-path ] change-path relative-to-request ; +M: string adjust-url ; + : ( url -- response ) adjust-url request get method>> { { "GET" [ ] } @@ -138,11 +142,11 @@ CHLOE: a string =value + present =value input/> ] [ 2drop ] if ; -: form-nesting-key "factorformnesting" ; +: form-nesting-key "__n" ; : form-magic ( tag -- ) [ modify-form ] each-responder diff --git a/extra/html/components/components-tests.factor b/extra/html/components/components-tests.factor index 1f77768115..2ae120b527 100644 --- a/extra/html/components/components-tests.factor +++ b/extra/html/components/components-tests.factor @@ -17,8 +17,6 @@ TUPLE: color red green blue ; [ ] [ "jimmy" "red" set-value ] unit-test -[ "123.5" ] [ 123.5 object>string ] unit-test - [ "jimmy" ] [ [ "red" label render diff --git a/extra/html/components/components.factor b/extra/html/components/components.factor index 90a00ed4ef..72dabad84e 100644 --- a/extra/html/components/components.factor +++ b/extra/html/components/components.factor @@ -5,7 +5,7 @@ classes.tuple words arrays sequences sequences.lib splitting mirrors hashtables combinators continuations math strings fry locals calendar calendar.format xml.entities validators html.elements html.streams xmode.code2html farkup inspector -lcs.diff2html urls ; +lcs.diff2html urls present ; IN: html.components SYMBOL: values @@ -29,19 +29,25 @@ SYMBOL: values : deposit-slots ( destination names -- ) [ ] dip deposit-values ; -: with-each-index ( name quot -- ) +: with-each-value ( name quot -- ) [ value ] dip '[ [ - blank-values - 1+ "index" set-value @ + values [ clone ] change + 1+ "index" set-value + "value" set-value + @ ] with-scope ] each-index ; inline -: with-each-value ( name quot -- ) - '[ "value" set-value @ ] with-each-index ; inline - : with-each-object ( name quot -- ) - '[ from-object @ ] with-each-index ; inline + [ value ] dip '[ + [ + blank-values + 1+ "index" set-value + from-object + @ + ] with-scope + ] each-index ; inline SYMBOL: nested-values @@ -75,13 +81,13 @@ GENERIC: render* ( value name render -- ) string =value input/> ; + ; PRIVATE> SINGLETON: label -M: label render* 2drop object>string escape-string write ; +M: label render* 2drop present escape-string write ; SINGLETON: hidden @@ -90,9 +96,9 @@ M: hidden render* drop "hidden" render-input ; : render-field ( value name size type -- ) string =size ] when* + [ present =size ] when* =name - object>string =value + present =value input/> ; TUPLE: field size ; @@ -119,11 +125,11 @@ TUPLE: textarea rows cols ; M: textarea render* ; ! Choice @@ -134,7 +140,7 @@ TUPLE: choice size multiple choices ; : render-option ( text selected? -- ) ; : render-options ( options selected -- ) @@ -143,7 +149,7 @@ TUPLE: choice size multiple choices ; M: choice render* " ] [ +[ "
" ] [ [ "test10" test-template call-template ] run-template @@ -168,3 +168,15 @@ TUPLE: person first-name last-name ; "test11" test-template call-template ] run-template [ blank? not ] filter ] unit-test + +[ ] [ + blank-values + { "a" "b" } "choices" set-value + "true" "b" set-value +] unit-test + +[ "ab" ] [ + [ + "test12" test-template call-template + ] run-template +] unit-test diff --git a/extra/html/templates/chloe/chloe.factor b/extra/html/templates/chloe/chloe.factor index cb56bd71ce..08d6b873fc 100644 --- a/extra/html/templates/chloe/chloe.factor +++ b/extra/html/templates/chloe/chloe.factor @@ -3,7 +3,7 @@ USING: accessors kernel sequences combinators kernel namespaces classes.tuple assocs splitting words arrays memoize io io.files io.encodings.utf8 io.streams.string -unicode.case tuple-syntax mirrors fry math urls +unicode.case tuple-syntax mirrors fry math urls present multiline xml xml.data xml.writer xml.utilities html.elements html.components @@ -127,7 +127,7 @@ CHLOE-TUPLE: code : expand-attrs ( tag -- tag ) dup [ tag? ] is? [ clone [ - [ "@" ?head [ value object>string ] when ] assoc-map + [ "@" ?head [ value present ] when ] assoc-map ] change-attrs ] when ; diff --git a/extra/html/templates/chloe/test/test12.xml b/extra/html/templates/chloe/test/test12.xml new file mode 100644 index 0000000000..b26778c96e --- /dev/null +++ b/extra/html/templates/chloe/test/test12.xml @@ -0,0 +1,3 @@ + + + diff --git a/extra/http/http.factor b/extra/http/http.factor index 7499796b77..abbf79f860 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -4,7 +4,7 @@ USING: accessors kernel combinators math namespaces assocs sequences splitting sorting sets debugger strings vectors hashtables quotations arrays byte-arrays -math.parser calendar calendar.format +math.parser calendar calendar.format present io io.server io.sockets.secure @@ -54,11 +54,9 @@ IN: http : header-value>string ( value -- string ) { - { [ dup number? ] [ number>string ] } { [ dup timestamp? ] [ timestamp>http-string ] } - { [ dup url? ] [ url>string ] } - { [ dup string? ] [ ] } - { [ dup sequence? ] [ [ header-value>string ] map "; " join ] } + { [ dup array? ] [ [ header-value>string ] map "; " join ] } + [ present ] } cond ; : check-header-string ( str -- str ) @@ -231,7 +229,7 @@ TUPLE: post-data raw content content-type ; dup method>> write bl ; : write-request-url ( request -- request ) - dup url>> relative-url url>string write bl ; + dup url>> relative-url present write bl ; : write-version ( request -- request ) "HTTP/" write dup request-version write crlf ; diff --git a/extra/http/server/dispatchers/dispatchers.factor b/extra/http/server/dispatchers/dispatchers.factor index 36eb447fc3..2da2695992 100644 --- a/extra/http/server/dispatchers/dispatchers.factor +++ b/extra/http/server/dispatchers/dispatchers.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces sequences assocs accessors -http http.server http.server.responses ; +USING: kernel namespaces sequences assocs accessors splitting +unicode.case http http.server http.server.responses ; IN: http.server.dispatchers TUPLE: dispatcher default responders ; @@ -31,8 +31,11 @@ TUPLE: vhost-dispatcher default responders ; : ( -- dispatcher ) vhost-dispatcher new-dispatcher ; +: canonical-host ( host -- host' ) + >lower "www." ?head drop "." ?tail drop ; + : find-vhost ( dispatcher -- responder ) - request get url>> host>> over responders>> at* + request get url>> host>> canonical-host over responders>> at* [ nip ] [ drop default>> ] if ; M: vhost-dispatcher call-responder* ( path dispatcher -- response ) diff --git a/extra/http/server/redirection/redirection-tests.factor b/extra/http/server/redirection/redirection-tests.factor index 0b88231855..04af89ec98 100644 --- a/extra/http/server/redirection/redirection-tests.factor +++ b/extra/http/server/redirection/redirection-tests.factor @@ -1,6 +1,6 @@ IN: http.server.redirection.tests USING: http http.server.redirection urls accessors -namespaces tools.test ; +namespaces tools.test present ; \ relative-to-request must-infer @@ -15,34 +15,34 @@ namespaces tools.test ; request set [ "http://www.apple.com:80/xxx/bar" ] [ - relative-to-request url>string + relative-to-request present ] unit-test [ "http://www.apple.com:80/xxx/baz" ] [ - "baz" >>path relative-to-request url>string + "baz" >>path relative-to-request present ] unit-test [ "http://www.apple.com:80/xxx/baz?c=d" ] [ - "baz" >>path { { "c" "d" } } >>query relative-to-request url>string + "baz" >>path { { "c" "d" } } >>query relative-to-request present ] unit-test [ "http://www.apple.com:80/xxx/bar?c=d" ] [ - { { "c" "d" } } >>query relative-to-request url>string + { { "c" "d" } } >>query relative-to-request present ] unit-test [ "http://www.apple.com:80/flip" ] [ - "/flip" >>path relative-to-request url>string + "/flip" >>path relative-to-request present ] unit-test [ "http://www.apple.com:80/flip?c=d" ] [ - "/flip" >>path { { "c" "d" } } >>query relative-to-request url>string + "/flip" >>path { { "c" "d" } } >>query relative-to-request present ] unit-test [ "http://www.jedit.org:80/" ] [ - "http://www.jedit.org" >url relative-to-request url>string + "http://www.jedit.org" >url relative-to-request present ] unit-test [ "http://www.jedit.org:80/?a=b" ] [ - "http://www.jedit.org" >url { { "a" "b" } } >>query relative-to-request url>string + "http://www.jedit.org" >url { { "a" "b" } } >>query relative-to-request present ] unit-test ] with-scope diff --git a/extra/present/present.factor b/extra/present/present.factor new file mode 100644 index 0000000000..1fae84184a --- /dev/null +++ b/extra/present/present.factor @@ -0,0 +1,15 @@ +USING: math math.parser calendar calendar.format strings words +kernel ; +IN: present + +GENERIC: present ( object -- string ) + +M: real present number>string ; + +M: timestamp present timestamp>string ; + +M: string present ; + +M: word present word-name ; + +M: f present drop "" ; diff --git a/extra/rss/rss.factor b/extra/rss/rss.factor index 5183af5145..1dd66ff5d4 100644 --- a/extra/rss/rss.factor +++ b/extra/rss/rss.factor @@ -4,7 +4,7 @@ USING: xml.utilities kernel assocs xml.generator math.order strings sequences xml.data xml.writer io.streams.string combinators xml xml.entities io.files io http.client namespaces xml.generator hashtables - calendar.format accessors continuations urls ; + calendar.format accessors continuations urls present ; IN: rss : any-tag-named ( tag names -- tag-inside ) @@ -104,7 +104,7 @@ C: entry : entry, ( entry -- ) "entry" [ dup title>> "title" { { "type" "html" } } simple-tag*, - "link" over link>> dup url? [ url>string ] when "href" associate contained*, + "link" over link>> dup url? [ present ] when "href" associate contained*, dup pub-date>> timestamp>rfc3339 "published" simple-tag, description>> [ "content" { { "type" "html" } } simple-tag*, ] when* ] tag, ; @@ -112,6 +112,6 @@ C: entry : feed>xml ( feed -- xml ) "feed" { { "xmlns" "http://www.w3.org/2005/Atom" } } [ dup title>> "title" simple-tag, - "link" over link>> dup url? [ url>string ] when "href" associate contained*, + "link" over link>> dup url? [ present ] when "href" associate contained*, entries>> [ entry, ] each ] make-xml* ; diff --git a/extra/urls/urls-tests.factor b/extra/urls/urls-tests.factor index 080352449b..a718989476 100644 --- a/extra/urls/urls-tests.factor +++ b/extra/urls/urls-tests.factor @@ -1,5 +1,7 @@ IN: urls.tests -USING: urls tools.test tuple-syntax arrays kernel assocs ; +USING: urls urls.private tools.test +tuple-syntax arrays kernel assocs +present ; [ "hello%20world" ] [ "hello world" url-encode ] unit-test [ "hello world" ] [ "hello%20world" url-decode ] unit-test @@ -110,7 +112,7 @@ urls [ ] assoc-each urls [ - swap [ 1array ] [ [ url>string ] curry ] bi* unit-test + swap [ 1array ] [ [ present ] curry ] bi* unit-test ] assoc-each [ "b" ] [ "a" "b" url-append-path ] unit-test diff --git a/extra/urls/urls.factor b/extra/urls/urls.factor index 5c89205d5b..bb4d17e1f5 100644 --- a/extra/urls/urls.factor +++ b/extra/urls/urls.factor @@ -4,7 +4,7 @@ USING: kernel unicode.categories combinators sequences splitting fry namespaces assocs arrays strings io.sockets io.sockets.secure io.encodings.string io.encodings.utf8 math math.parser accessors mirrors parser -prettyprint.backend hashtables ; +prettyprint.backend hashtables present ; IN: urls : url-quotable? ( ch -- ? ) @@ -14,19 +14,25 @@ IN: urls { [ dup letter? ] [ t ] } { [ dup LETTER? ] [ t ] } { [ dup digit? ] [ t ] } - { [ dup "/_-.:" member? ] [ t ] } + { [ dup "/_-." member? ] [ t ] } [ f ] } cond nip ; foldable +hex 2 CHAR: 0 pad-left % ] each ; +PRIVATE> + : url-encode ( str -- str ) [ [ dup url-quotable? [ , ] [ push-utf8 ] if ] each ] "" make ; += [ 2drop @@ -51,9 +57,13 @@ IN: urls ] if url-decode-iter ] if ; +PRIVATE> + : url-decode ( str -- str ) [ 0 swap url-decode-iter ] "" make utf8 decode ; + + : query>assoc ( query -- assoc ) dup [ "&" split H{ } clone [ @@ -77,11 +89,7 @@ IN: urls : assoc>query ( hash -- str ) [ - { - { [ dup number? ] [ number>string 1array ] } - { [ dup string? ] [ 1array ] } - { [ dup sequence? ] [ ] } - } cond + dup array? [ [ present ] map ] [ present 1array ] if ] assoc-map [ [ @@ -108,6 +116,8 @@ TUPLE: url protocol username password host port path query anchor ; ] when ] bi* ; +>protocol ] [ "//" ?head [ "Invalid URL" throw ] unless @@ -121,6 +131,8 @@ TUPLE: url protocol username password host port path query anchor ; ] [ "/" prepend ] bi* ] bi* ; +PRIVATE> + GENERIC: >url ( obj -- url ) M: url >url ; @@ -135,6 +147,8 @@ M: string >url ] [ url-decode >>anchor ] bi* ; +> dup [ % password>> [ ":" % % ] when* "@" % @@ -150,7 +164,7 @@ M: string >url [ path>> "/" head? [ "/" % ] unless ] } cleave ; -: url>string ( url -- string ) +M: url present [ { [ dup protocol>> dup [ unparse-host-part ] [ 2drop ] if ] @@ -169,6 +183,8 @@ M: string >url [ [ "/" last-split1 drop "/" ] dip 3append ] } cond ; +PRIVATE> + : derive-url ( base url -- url' ) [ clone dup ] dip 2dup [ path>> ] bi@ url-append-path @@ -199,4 +215,4 @@ M: string >url ! Literal syntax : URL" lexer get skip-blank parse-string >url parsed ; parsing -M: url pprint* dup url>string "URL\" " "\"" pprint-string ; +M: url pprint* dup present "URL\" " "\"" pprint-string ;