1 ! Copyright (C) 2008, 2011 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
4 USING: accessors arrays assocs combinators fry hashtables
5 io.pathnames io.sockets kernel lexer make math.parser
6 namespaces peg.ebnf present sequences splitting strings
7 strings.parser urls.encoding vocabs vocabs.loader ;
11 TUPLE: url protocol username password host port path query anchor ;
13 : <url> ( -- url ) url new ;
15 : query-param ( url key -- value )
18 : delete-query-param ( url key -- url )
19 over query>> delete-at ;
21 : set-query-param ( url value key -- url )
23 '[ [ _ _ ] dip ?set-at ] change-query
25 nip delete-query-param
28 ERROR: malformed-port ;
30 : parse-host ( string -- host/f port/f )
32 ":" split1-last [ url-decode ]
33 [ dup [ string>number [ malformed-port ] unless* ] when ] bi*
36 GENERIC: >url ( obj -- url )
38 M: f >url drop <url> ;
46 protocol = [a-z+]+ => [[ url-decode ]]
47 username = [^/:@#?]+ => [[ url-decode ]]
48 password = [^/:@#?]+ => [[ url-decode ]]
49 pathname = [^#?]+ => [[ url-decode ]]
50 query = [^#]+ => [[ query>assoc ]]
51 anchor = .+ => [[ url-decode ]]
53 hostname = [^/#?]+ => [[ url-decode ]]
55 hostname-spec = hostname ("/"|!(.)) => [[ first ]]
57 auth = (username (":" password => [[ second ]])? "@"
58 => [[ first2 2array ]])?
60 url = (((protocol "://") => [[ first ]] auth hostname)
61 | (("//") => [[ f ]] auth hostname))?
63 ("?" query => [[ second ]])?
64 ("#" anchor => [[ second ]])?
78 [ first [ first2 [ >>username ] [ >>password ] bi* ] when* ]
79 [ second parse-host [ >>host ] [ >>port ] bi* ] bi
87 dup host>> [ [ "/" or ] change-path ] when ;
89 M: pathname >url string>> >url ;
91 : relative-url ( url -- url' )
97 : relative-url? ( url -- ? ) protocol>> not ;
101 : unparse-username-password ( url -- )
103 % password>> [ ":" % % ] when* "@" %
106 : url-port ( url -- port/f )
107 [ port>> ] [ port>> ] [ protocol>> protocol-port ] tri =
110 : unparse-host-part ( url -- )
112 [ unparse-username-password ]
113 [ host>> url-encode % ]
114 [ url-port [ ":" % # ] when* ]
115 [ path>> "/" head? [ "/" % ] unless ]
118 ! URL" //foo.com" takes on the protocol of the url it's derived from
119 : unparse-protocol ( url -- )
121 % "://" % unparse-host-part
124 "//" % unparse-host-part
134 [ path>> url-encode % ]
135 [ query>> dup assoc-empty? [ drop ] [ "?" % assoc>query % ] if ]
136 [ anchor>> [ "#" % present url-encode % ] when* ]
142 : url-append-path ( path1 path2 -- path )
144 { [ dup "/" head? ] [ nip ] }
145 { [ dup empty? ] [ drop ] }
146 { [ over "/" tail? ] [ append ] }
147 { [ "/" pick start not ] [ nip ] }
148 [ [ "/" split1-last drop "/" ] dip 3append ]
153 : derive-port ( url base -- url' )
154 over relative-url? [ [ port>> ] either? ] [ drop port>> ] if ;
156 : derive-path ( url base -- url' )
157 [ path>> ] bi@ swap url-append-path ;
161 : derive-url ( base url -- url' )
163 [ [ protocol>> ] either? >>protocol ]
164 [ [ username>> ] either? >>username ]
165 [ [ password>> ] either? >>password ]
166 [ [ host>> ] either? >>host ]
167 [ derive-port >>port ]
168 [ derive-path >>path ]
169 [ [ query>> ] either? >>query ]
170 [ [ anchor>> ] either? >>anchor ]
173 ! Half-baked stuff follows
174 : secure-protocol? ( protocol -- ? )
179 GENERIC: >secure-addr ( addrspec -- addrspec' )
183 : url-addr ( url -- addr )
187 [ protocol>> protocol-port ]
190 secure-protocol? [ "urls.secure" ensure-vocab-loaded >secure-addr ] when ;
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-short-string >url suffix! ;
201 { "urls" "prettyprint" } "urls.prettyprint" require-when
202 { "urls" "io.sockets.secure" } "urls.secure" require-when