1 ! Copyright (C) 2008, 2011 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
4 USING: accessors ascii assocs combinators
5 combinators.short-circuit fry io.pathnames io.sockets
6 io.sockets.secure kernel lexer linked-assocs make math
7 math.parser multiline namespaces peg.ebnf present sequences
8 sequences.generalizations splitting strings strings.parser
9 urls.encoding vocabs.loader ;
13 TUPLE: url protocol username password host port path query anchor ;
15 : <url> ( -- url ) url new ;
17 : query-param ( url key -- value )
20 : set-or-delete ( value key query -- )
21 pick [ set-at ] [ delete-at drop ] if ;
23 : set-query-param ( url value key -- url )
24 pick query>> [ <linked-hash> ] unless* [ set-or-delete ] keep >>query ;
26 : set-query-params ( url params -- url )
27 [ swap set-query-param ] assoc-each ;
29 ERROR: malformed-port string ;
31 : parse-port ( string -- port/f )
32 [ f ] [ dup string>number [ ] [ malformed-port ] ?if ] if-empty ;
34 : parse-host ( string -- host/f port/f )
36 ":" split1-last [ url-decode ] [ parse-port ] bi*
39 GENERIC: >url ( obj -- url )
41 M: f >url drop <url> ;
49 protocol = [a-zA-Z0-9.+-]+ => [[ url-decode ]]
50 username = [^/:@#?]* => [[ url-decode ]]
51 password = [^/:@#?]* => [[ url-decode ]]
52 path = [^#?]+ => [[ url-decode ]]
53 query = [^#]+ => [[ query>assoc ]]
54 anchor = .+ => [[ url-decode ]]
55 hostname = [^/#?:]+ => [[ url-decode ]]
56 ipv6 = "[" [^\]]+ "]" => [[ concat url-decode ]]
57 port = [^/#?]+ => [[ url-decode parse-port ]]
59 auth = username (":"~ password?)? "@"~
60 host = (ipv6 | hostname) (":"~ port?)?
62 url = (protocol ":"~)?
73 [ <url> ] dip parse-url 5 firstn {
77 [ first [ first2 [ >>username ] [ >>password ] bi* ] when* ]
78 [ second [ first2 [ >>host ] [ >>port ] bi* ] when* ] bi
84 } spread dup host>> [ [ "/" or ] change-path ] when ;
86 M: pathname >url string>> >url ;
88 : relative-url ( url -- url' )
94 : relative-url? ( url -- ? ) protocol>> not ;
98 : unparse-username-password ( url -- )
100 % password>> [ ":" % % ] when* "@" %
103 : url-port ( url -- port/f )
104 [ port>> ] [ protocol>> protocol-port ] bi over =
107 : ipv6-host ( host -- host/ipv6 ipv6? )
108 dup { [ "[" head? ] [ "]" tail? ] } 1&& [
109 1 swap [ length 1 - ] [ subseq ] bi t
112 : unparse-host ( url -- host )
113 host>> ipv6-host [ url-encode ] [ [ "[" "]" surround ] when ] bi* ;
115 : unparse-host-part ( url -- )
117 [ unparse-username-password ]
119 [ url-port [ ":" % # ] when* ]
120 [ path>> "/" head? [ "/" % ] unless ]
123 ! URL" //foo.com" takes on the protocol of the url it's derived from
124 : unparse-protocol ( url -- )
125 protocol>> [ % ":" % ] when* ;
127 : unparse-authority ( url -- )
128 dup host>> [ "//" % unparse-host-part ] [ drop ] if ;
134 [ unparse-authority ]
135 [ path>> url-encode % ]
136 [ query>> dup assoc-empty? [ drop ] [ "?" % assoc>query % ] if ]
137 [ anchor>> [ "#" % present url-encode % ] when* ]
143 : url-append-path ( path1 path2 -- path )
145 { [ dup "/" head? ] [ nip ] }
146 { [ dup empty? ] [ drop ] }
147 { [ over "/" tail? ] [ append ] }
148 { [ "/" pick subseq-start not ] [ nip ] }
149 [ [ "/" split1-last drop "/" ] dip 3append ]
154 : derive-port ( url base -- url' )
155 over relative-url? [ [ port>> ] either? ] [ drop port>> ] if ;
157 : derive-path ( url base -- url' )
158 [ path>> ] bi@ swap url-append-path ;
162 : derive-url ( base url -- url' )
164 [ [ protocol>> ] either? >>protocol ]
165 [ [ username>> ] either? >>username ]
166 [ [ password>> ] either? >>password ]
167 [ [ host>> ] either? >>host ]
168 [ derive-port >>port ]
169 [ derive-path >>path ]
170 [ [ query>> ] either? >>query ]
171 [ [ anchor>> ] either? >>anchor ]
174 : redacted-url ( url -- url' )
175 clone [ "xxxxx" and ] change-password ;
177 ! Half-baked stuff follows
178 : secure-protocol? ( protocol -- ? )
181 : url-addr ( url -- addr )
183 [ host>> ipv6-host drop ]
185 [ protocol>> protocol-port ]
188 dup protocol>> secure-protocol?
189 [ host>> ipv6-host drop <secure> ] [ drop ] if
192 : set-url-addr ( url addr -- url )
193 [ host>> >>host ] [ port>> >>port ] bi ;
195 : ensure-port ( url -- url' )
196 clone dup protocol>> '[ _ protocol-port or ] change-port ;
199 SYNTAX: URL" lexer get skip-blank parse-string >url suffix! ;
201 { "urls" "prettyprint" } "urls.prettyprint" require-when