-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2011 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel ascii combinators combinators.short-circuit
-sequences splitting fry namespaces make assocs arrays strings
-io.sockets io.encodings.string io.encodings.utf8 math
-math.parser accessors parser strings.parser lexer
-hashtables present peg.ebnf urls.encoding ;
+
+USING: accessors ascii assocs combinators
+combinators.short-circuit io.pathnames io.sockets
+io.sockets.secure kernel lexer linked-assocs make math.parser
+multiline namespaces peg.ebnf present sequences
+sequences.generalizations splitting strings strings.parser
+urls.encoding vocabs.loader ;
+
IN: urls
TUPLE: url protocol username password host port path query anchor ;
: query-param ( url key -- value )
swap query>> at ;
-: delete-query-param ( url key -- url )
- over query>> delete-at ;
+: set-or-delete ( value key query -- )
+ pick [ set-at ] [ delete-at drop ] if ;
: set-query-param ( url value key -- url )
- over [
- '[ [ _ _ ] dip ?set-at ] change-query
- ] [
- nip delete-query-param
- ] if ;
+ pick query>> [ <linked-hash> ] unless* [ set-or-delete ] keep >>query ;
+
+: set-query-params ( url params -- url )
+ [ swap set-query-param ] assoc-each ;
+
+ERROR: malformed-port string ;
+
+: parse-port ( string -- port/f )
+ [ f ] [ dup string>number [ ] [ malformed-port ] ?if ] if-empty ;
-: parse-host ( string -- host port )
- ":" split1 [ url-decode ] [
- dup [
- string>number
- dup [ "Invalid port" throw ] unless
- ] when
- ] bi* ;
+: parse-host ( string -- host/f port/f )
+ [
+ ":" split1-last [ url-decode ] [ parse-port ] bi*
+ ] [ f f ] if* ;
GENERIC: >url ( obj -- url )
<PRIVATE
-EBNF: parse-url
-
-protocol = [a-z]+ => [[ url-decode ]]
-username = [^/:@#?]+ => [[ url-decode ]]
-password = [^/:@#?]+ => [[ url-decode ]]
-pathname = [^#?]+ => [[ url-decode ]]
-query = [^#]+ => [[ query>assoc ]]
-anchor = .+ => [[ url-decode ]]
-
-hostname = [^/#?]+ => [[ url-decode ]]
-
-hostname-spec = hostname ("/"|!(.)) => [[ first ]]
-
-auth = (username (":" password => [[ second ]])? "@"
- => [[ first2 2array ]])?
-
-url = ((protocol "://") => [[ first ]] auth hostname)?
- (pathname)?
- ("?" query => [[ second ]])?
- ("#" anchor => [[ second ]])?
-
-;EBNF
+: remove-dot-segments ( path -- path' )
+ [ "//" split1 ] [ "/" glue ] while*
+ [ "/./" split1 ] [ "/" glue ] while*
+ [ "/../" split1 ] [ [ "/" split1-last drop ] dip "/" glue ] while*
+ "/.." ?tail [ "/" split1-last drop "/" append ] when
+ "../" ?head [ "/" prepend ] when
+ "./" ?head [ "/" prepend ] when
+ "/." ?tail [ "/" append ] when
+ [ "/" ] when-empty ;
+
+: parse-path ( string -- path )
+ "/" split [ url-decode "/" "%2F" replace ] map "/" join
+ remove-dot-segments ;
+
+EBNF: parse-url [=[
+
+protocol = [a-zA-Z0-9.+-]+ => [[ url-decode ]]
+username = [^/:@#?]* => [[ url-decode ]]
+password = [^/:@#?]* => [[ url-decode ]]
+path = [^#?]+ => [[ parse-path ]]
+query = [^#]+ => [[ query>assoc ]]
+anchor = .+ => [[ url-decode ]]
+hostname = [^/#?:]+ => [[ url-decode ]]
+ipv6 = "[" [^\]]+ "]" => [[ concat url-decode ]]
+port = [^/#?]+ => [[ url-decode parse-port ]]
+
+auth = username (":"~ password?)? "@"~
+host = (ipv6 | hostname) (":"~ port?)?
+
+url = (protocol ":"~)?
+ ("//"~ auth? host?)?
+ path?
+ ("?"~ query?)?
+ ("#"~ anchor?)?
+
+]=]
PRIVATE>
M: string >url
- parse-url {
+ [ <url> ] dip parse-url 5 firstn {
+ [ >lower >>protocol ]
[
- first [
- [ first ] ! protocol
- [
- second
- [ first [ first2 ] [ f f ] if* ] ! username, password
- [ second parse-host ] ! host, port
- bi
- ] bi
- ] [ f f f f f ] if*
+ [
+ [ first [ first2 [ >>username ] [ >>password ] bi* ] when* ]
+ [ second [ first2 [ >>host ] [ >>port ] bi* ] when* ] bi
+ ] when*
]
- [ second ] ! pathname
- [ third ] ! query
- [ fourth ] ! anchor
- } cleave url boa
- dup host>> [ [ "/" or ] change-path ] when ;
+ [ >>path ]
+ [ >>query ]
+ [ >>anchor ]
+ } spread dup host>> [ [ "/" or ] change-path ] when ;
-: protocol-port ( protocol -- port )
- {
- { "http" [ 80 ] }
- { "https" [ 443 ] }
- { "ftp" [ 21 ] }
- [ drop f ]
- } case ;
+M: pathname >url string>> >url ;
+
+: relative-url ( url -- url' )
+ clone
+ f >>protocol
+ f >>host
+ f >>port ;
+
+: relative-url? ( url -- ? ) protocol>> not ;
<PRIVATE
: unparse-username-password ( url -- )
dup username>> dup [
- % password>> [ ":" % % ] when* "@" %
+ url-encode % password>> [ ":" % url-encode % ] when* "@" %
] [ 2drop ] if ;
: url-port ( url -- port/f )
- [ port>> ] [ port>> ] [ protocol>> protocol-port ] tri =
+ [ port>> ] [ protocol>> protocol-port ] bi over =
[ drop f ] when ;
-: unparse-host-part ( url protocol -- )
- %
- "://" %
+: ipv6-host ( host -- host/ipv6 ipv6? )
+ dup { [ "[" head? ] [ "]" tail? ] } 1&& [
+ 1 swap index-of-last subseq t
+ ] [ f ] if ;
+
+: unparse-host ( url -- host )
+ host>> ipv6-host [ url-encode ] [ [ "[" "]" surround ] when ] bi* ;
+
+: unparse-host-part ( url -- )
{
[ unparse-username-password ]
- [ host>> url-encode % ]
+ [ unparse-host % ]
[ url-port [ ":" % # ] when* ]
[ path>> "/" head? [ "/" % ] unless ]
} cleave ;
-PRIVATE>
+! URL" //foo.com" takes on the protocol of the url it's derived from
+: unparse-protocol ( url -- )
+ protocol>> [ % ":" % ] when* ;
+
+: unparse-authority ( url -- )
+ dup host>> [ "//" % unparse-host-part ] [ drop ] if ;
+
+: unparse-path ( url -- )
+ path>> "/" split [
+ "%2F" "/" replace url-encode "/" "%2F" replace
+ ] map "/" join % ;
M: url present
[
{
- [ dup protocol>> dup [ unparse-host-part ] [ 2drop ] if ]
- [ path>> url-encode % ]
+ [ unparse-protocol ]
+ [ unparse-authority ]
+ [ unparse-path ]
[ query>> dup assoc-empty? [ drop ] [ "?" % assoc>query % ] if ]
[ anchor>> [ "#" % present url-encode % ] when* ]
} cleave
] "" make ;
+PRIVATE>
+
: url-append-path ( path1 path2 -- path )
{
{ [ dup "/" head? ] [ nip ] }
{ [ dup empty? ] [ drop ] }
{ [ over "/" tail? ] [ append ] }
- { [ "/" pick start not ] [ nip ] }
+ { [ over "/" subseq-index not ] [ nip ] }
[ [ "/" split1-last drop "/" ] dip 3append ]
- } cond ;
+ } cond remove-dot-segments ;
+
+<PRIVATE
+
+: derive-port ( url base -- url' )
+ over relative-url? [ [ port>> ] either? ] [ drop port>> ] if ;
+
+: derive-path ( url base -- url' )
+ [ path>> ] bi@ swap url-append-path ;
PRIVATE>
[ [ username>> ] either? >>username ]
[ [ password>> ] either? >>password ]
[ [ host>> ] either? >>host ]
- [ [ port>> ] either? >>port ]
- [ [ path>> ] bi@ swap url-append-path >>path ]
+ [ derive-port >>port ]
+ [ derive-path >>path ]
[ [ query>> ] either? >>query ]
[ [ anchor>> ] either? >>anchor ]
} 2cleave ;
-: relative-url ( url -- url' )
- clone
- f >>protocol
- f >>host
- f >>port ;
-
-: relative-url? ( url -- ? ) protocol>> not ;
+: redacted-url ( url -- url' )
+ clone [ "xxxxx" and ] change-password ;
! Half-baked stuff follows
: secure-protocol? ( protocol -- ? )
"https" = ;
-<PRIVATE
-
-GENERIC: >secure-addr ( addrspec -- addrspec' )
-
-PRIVATE>
-
: url-addr ( url -- addr )
[
- [ host>> ]
+ [ host>> ipv6-host drop ]
[ port>> ]
[ protocol>> protocol-port ]
tri or <inet>
- ] [ protocol>> ] bi
- secure-protocol? [ >secure-addr ] when ;
+ ] [
+ dup protocol>> secure-protocol?
+ [ host>> ipv6-host drop <secure> ] [ drop ] if
+ ] bi ;
+
+: set-url-addr ( url addr -- url )
+ [ [ host>> ] [ inet6? ] bi [ "[" "]" surround ] when >>host ]
+ [ port>> >>port ] bi ;
: ensure-port ( url -- url' )
clone dup protocol>> '[ _ protocol-port or ] change-port ;
! Literal syntax
-SYNTAX: URL" lexer get skip-blank parse-string >url parsed ;
-
-USING: vocabs vocabs.loader ;
+SYNTAX: URL" lexer get skip-blank parse-string >url suffix! ;
-"prettyprint" vocab [
- "urls.prettyprint" require
-] when
+{ "urls" "prettyprint" } "urls.prettyprint" require-when
projects / factor.git / blobdiff