Various furnace improvements; add present vocabulary for converting objects to human-readable strings
parent
8ef7f4d904
commit
99b23348a8
|
@ -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
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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='&&&' />" ]
|
||||
[ "<input type='hidden' name='foo' value='&&&'/>" ]
|
||||
[ [ "&&&" "foo" hidden-form-field ] with-string-writer ]
|
||||
unit-test
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 } ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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>
|
|
@ -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 ;
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 "" ;
|
|
@ -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* ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
Loading…
Reference in New Issue