Various furnace improvements; add present vocabulary for converting objects to human-readable strings

db4
Slava Pestov 2008-06-05 00:18:36 -05:00
parent 8ef7f4d904
commit 99b23348a8
17 changed files with 149 additions and 79 deletions

View File

@ -21,3 +21,21 @@ blah
init-request
{ } "action-1" get call-responder
] unit-test
<action>
"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

View File

@ -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 <flash-redirect> ] [ <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 )

View File

@ -30,6 +30,6 @@ M: base-path-check-responder call-responder*
"a/b/c" split-path main-responder get call-responder body>>
] unit-test
[ "<input type='hidden' name='foo' value='&amp;&amp;&amp;' />" ]
[ "<input type='hidden' name='foo' value='&amp;&amp;&amp;'/>" ]
[ [ "&&&" "foo" hidden-form-field ] with-string-writer ]
unit-test

View File

@ -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 ;
: <redirect> ( url -- response )
adjust-url request get method>> {
{ "GET" [ <temporary-redirect> ] }
@ -138,11 +142,11 @@ CHLOE: a
<input
"hidden" =type
=name
object>string =value
present =value
input/>
] [ 2drop ] if ;
: form-nesting-key "factorformnesting" ;
: form-nesting-key "__n" ;
: form-magic ( tag -- )
[ modify-form ] each-responder

View File

@ -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

View File

@ -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 -- )
[ <mirror> ] 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 -- )
<PRIVATE
: render-input ( value name type -- )
<input =type =name object>string =value input/> ;
<input =type =name present =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 -- )
<input
=type
[ object>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*
<textarea
[ rows>> [ object>string =rows ] when* ]
[ cols>> [ object>string =cols ] when* ] bi
[ rows>> [ present =rows ] when* ]
[ cols>> [ present =cols ] when* ] bi
=name
textarea>
object>string escape-string write
present escape-string write
</textarea> ;
! Choice
@ -134,7 +140,7 @@ TUPLE: choice size multiple choices ;
: render-option ( text selected? -- )
<option [ "true" =selected ] when option>
object>string escape-string write
present escape-string write
</option> ;
: render-options ( options selected -- )
@ -143,7 +149,7 @@ TUPLE: choice size multiple choices ;
M: choice render*
<select
swap =name
dup size>> [ object>string =size ] when*
dup size>> [ present =size ] when*
dup multiple>> [ "true" =multiple ] when
select>
[ choices>> value ] [ multiple>> ] bi
@ -170,12 +176,18 @@ M: checkbox render*
GENERIC: link-title ( obj -- string )
GENERIC: link-href ( obj -- url )
M: string link-title ;
M: string link-href ;
M: url link-title ;
M: url link-href ;
SINGLETON: link
M: link render*
2drop
<a dup link-href =href a>
link-title object>string escape-string write
link-title present escape-string write
</a> ;
! XMode code component

View File

@ -5,7 +5,7 @@
USING: io kernel namespaces prettyprint quotations
sequences strings words xml.entities compiler.units effects
urls math math.parser combinators calendar calendar.format ;
urls math math.parser combinators present ;
IN: html.elements
@ -127,22 +127,11 @@ SYMBOL: html
dup def-for-html-word-<foo
def-for-html-word-foo/> ;
: object>string ( object -- string )
#! Should this be generic and in the core?
{
{ [ dup real? ] [ number>string ] }
{ [ dup timestamp? ] [ timestamp>string ] }
{ [ dup url? ] [ url>string ] }
{ [ dup string? ] [ ] }
{ [ dup word? ] [ word-name ] }
{ [ dup not ] [ drop "" ] }
} cond ;
: write-attr ( value name -- )
" " write-html
write-html
"='" write-html
object>string escape-quoted-string write-html
present escape-quoted-string write-html
"'" write-html ;
: attribute-effect T{ effect f { "string" } 0 } ;

View File

@ -151,7 +151,7 @@ TUPLE: person first-name last-name ;
[ ] [ H{ { "a" H{ { "b" "c" } } } } values set ] unit-test
[ "<form method='POST' action='foo'><input type='hidden' name='factorformnesting' value='a'/></form>" ] [
[ "<form method='POST' action='foo'><input type='hidden' name='__n' value='a'/></form>" ] [
[
"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
[ "<input type='checkbox' name='a'>a</input><input type='checkbox' name='b' checked='true'>b</input>" ] [
[
"test12" test-template call-template
] run-template
] unit-test

View File

@ -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 ;

View File

@ -0,0 +1,3 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0"><t:each t:name="choices"><t:checkbox t:name="@value" t:label="@value" /></t:each></t:chloe>

View File

@ -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 ;

View File

@ -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 ;
: <vhost-dispatcher> ( -- 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 )

View File

@ -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" ] [
<url> relative-to-request url>string
<url> relative-to-request present
] unit-test
[ "http://www.apple.com:80/xxx/baz" ] [
<url> "baz" >>path relative-to-request url>string
<url> "baz" >>path relative-to-request present
] unit-test
[ "http://www.apple.com:80/xxx/baz?c=d" ] [
<url> "baz" >>path { { "c" "d" } } >>query relative-to-request url>string
<url> "baz" >>path { { "c" "d" } } >>query relative-to-request present
] unit-test
[ "http://www.apple.com:80/xxx/bar?c=d" ] [
<url> { { "c" "d" } } >>query relative-to-request url>string
<url> { { "c" "d" } } >>query relative-to-request present
] unit-test
[ "http://www.apple.com:80/flip" ] [
<url> "/flip" >>path relative-to-request url>string
<url> "/flip" >>path relative-to-request present
] unit-test
[ "http://www.apple.com:80/flip?c=d" ] [
<url> "/flip" >>path { { "c" "d" } } >>query relative-to-request url>string
<url> "/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

View File

@ -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 "" ;

View File

@ -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 -- )
"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> 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* ;

View File

@ -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

View File

@ -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
<PRIVATE
: push-utf8 ( ch -- )
1string utf8 encode
[ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
PRIVATE>
: url-encode ( str -- str )
[
[ dup url-quotable? [ , ] [ push-utf8 ] if ] each
] "" make ;
<PRIVATE
: url-decode-hex ( index str -- )
2dup length 2 - >= [
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 ;
<PRIVATE
: add-query-param ( value key assoc -- )
[
at [
@ -65,6 +75,8 @@ IN: urls
] when*
] 2keep set-at ;
PRIVATE>
: 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* ;
<PRIVATE
: parse-host-part ( url protocol rest -- url string' )
[ >>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* ;
<PRIVATE
: unparse-username-password ( url -- )
dup username>> 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 ;