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
\r
SYMBOL: params\r
\r
-SYMBOL: rest-param\r
+SYMBOL: rest\r
\r
: render-validation-messages ( -- )\r
validation-messages get\r
\r
CHLOE: validation-messages drop render-validation-messages ;\r
\r
-TUPLE: action rest-param init display validate submit ;\r
+TUPLE: action rest init display validate submit ;\r
\r
: new-action ( class -- action )\r
new\r
[ flashed-variables <flash-redirect> ] [ <403> ] if*\r
] unless* ;\r
\r
-: handle-rest-param ( path action -- assoc )\r
- rest-param>> dup [ associate ] [ 2drop f ] if ;\r
+: handle-rest ( path action -- assoc )\r
+ rest>> dup [ [ "/" join ] dip associate ] [ 2drop f ] if ;\r
\r
: init-action ( path action -- )\r
blank-values\r
init-validation\r
- handle-rest-param\r
+ handle-rest\r
request get request-params assoc-union params set ;\r
\r
M: action call-responder* ( path action -- response )\r
"a/b/c" split-path main-responder get call-responder body>>
] unit-test
-[ "<input type='hidden' name='foo' value='&&&' />" ]
+[ "<input type='hidden' name='foo' value='&&&'/>" ]
[ [ "&&&" "foo" hidden-form-field ] with-string-writer ]
unit-test
! 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
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> ] }
<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
[ ] [ "jimmy" "red" set-value ] unit-test
-[ "123.5" ] [ 123.5 object>string ] unit-test
-
[ "jimmy" ] [
[
"red" label render
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
: 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
<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
: 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 ;
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
: render-option ( text selected? -- )
<option [ "true" =selected ] when option>
- object>string escape-string write
+ present escape-string write
</option> ;
: render-options ( options selected -- )
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
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
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
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 } ;
[ ] [ 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
"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
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
: expand-attrs ( tag -- tag )
dup [ tag? ] is? [
clone [
- [ "@" ?head [ value object>string ] when ] assoc-map
+ [ "@" ?head [ value present ] when ] assoc-map
] change-attrs
] when ;
--- /dev/null
+<?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>
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
: 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 )
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 ;
! 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 ;
: <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 )
IN: http.server.redirection.tests
USING: http http.server.redirection urls accessors
-namespaces tools.test ;
+namespaces tools.test present ;
\ relative-to-request must-infer
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
--- /dev/null
+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 "" ;
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 )
: 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, ;
: 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* ;
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
] 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
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 -- ? )
{ [ 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
] 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 [
] when*
] 2keep set-at ;
+PRIVATE>
+
: query>assoc ( query -- assoc )
dup [
"&" split H{ } clone [
: assoc>query ( hash -- str )
[
- {
- { [ dup number? ] [ number>string 1array ] }
- { [ dup string? ] [ 1array ] }
- { [ dup sequence? ] [ ] }
- } cond
+ dup array? [ [ present ] map ] [ present 1array ] if
] assoc-map
[
[
] when
] bi* ;
+<PRIVATE
+
: parse-host-part ( url protocol rest -- url string' )
[ >>protocol ] [
"//" ?head [ "Invalid URL" throw ] unless
] [ "/" prepend ] bi*
] bi* ;
+PRIVATE>
+
GENERIC: >url ( obj -- url )
M: url >url ;
]
[ url-decode >>anchor ] bi* ;
+<PRIVATE
+
: unparse-username-password ( url -- )
dup username>> dup [
% password>> [ ":" % % ] when* "@" %
[ path>> "/" head? [ "/" % ] unless ]
} cleave ;
-: url>string ( url -- string )
+M: url present
[
{
[ dup protocol>> dup [ unparse-host-part ] [ 2drop ] if ]
[ [ "/" last-split1 drop "/" ] dip 3append ]
} cond ;
+PRIVATE>
+
: derive-url ( base url -- url' )
[ clone dup ] dip
2dup [ path>> ] bi@ url-append-path
! 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 ;
projects / factor.git / commitdiff