1 ! Copyright (C) 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: kernel ascii combinators combinators.short-circuit
4 sequences splitting fry namespaces make assocs arrays strings
5 io.sockets io.encodings.string io.encodings.utf8 math
6 math.parser accessors parser strings.parser lexer
7 hashtables present peg.ebnf urls.encoding ;
10 TUPLE: url protocol username password host port path query anchor ;
12 : <url> ( -- url ) url new ;
14 : query-param ( url key -- value )
17 : delete-query-param ( url key -- url )
18 over query>> delete-at ;
20 : set-query-param ( url value key -- url )
22 '[ [ _ _ ] dip ?set-at ] change-query
24 nip delete-query-param
27 : parse-host ( string -- host port )
29 ":" split1 [ url-decode ] [
32 dup [ "Invalid port" throw ] unless
37 GENERIC: >url ( obj -- url )
39 M: f >url drop <url> ;
47 protocol = [a-z]+ => [[ url-decode ]]
48 username = [^/:@#?]+ => [[ url-decode ]]
49 password = [^/:@#?]+ => [[ url-decode ]]
50 pathname = [^#?]+ => [[ url-decode ]]
51 query = [^#]+ => [[ query>assoc ]]
52 anchor = .+ => [[ url-decode ]]
54 hostname = [^/#?]+ => [[ url-decode ]]
56 hostname-spec = hostname ("/"|!(.)) => [[ first ]]
58 auth = (username (":" password => [[ second ]])? "@"
59 => [[ first2 2array ]])?
61 url = ((protocol "://") => [[ first ]] auth hostname)?
63 ("?" query => [[ second ]])?
64 ("#" anchor => [[ second ]])?
77 [ first [ first2 ] [ f f ] if* ] ! username, password
78 [ second parse-host ] ! host, port
87 dup host>> [ [ "/" or ] change-path ] when ;
89 : protocol-port ( protocol -- port )
99 : unparse-username-password ( url -- )
101 % password>> [ ":" % % ] when* "@" %
104 : url-port ( url -- port/f )
105 [ port>> ] [ port>> ] [ protocol>> protocol-port ] tri =
108 : unparse-host-part ( url protocol -- )
112 [ unparse-username-password ]
113 [ host>> url-encode % ]
114 [ url-port [ ":" % # ] when* ]
115 [ path>> "/" head? [ "/" % ] unless ]
123 [ dup protocol>> dup [ unparse-host-part ] [ 2drop ] if ]
124 [ path>> url-encode % ]
125 [ query>> dup assoc-empty? [ drop ] [ "?" % assoc>query % ] if ]
126 [ anchor>> [ "#" % present url-encode % ] when* ]
130 : url-append-path ( path1 path2 -- path )
132 { [ dup "/" head? ] [ nip ] }
133 { [ dup empty? ] [ drop ] }
134 { [ over "/" tail? ] [ append ] }
135 { [ "/" pick start not ] [ nip ] }
136 [ [ "/" split1-last drop "/" ] dip 3append ]
141 : derive-url ( base url -- url' )
143 [ [ protocol>> ] either? >>protocol ]
144 [ [ username>> ] either? >>username ]
145 [ [ password>> ] either? >>password ]
146 [ [ host>> ] either? >>host ]
147 [ [ port>> ] either? >>port ]
148 [ [ path>> ] bi@ swap url-append-path >>path ]
149 [ [ query>> ] either? >>query ]
150 [ [ anchor>> ] either? >>anchor ]
153 : relative-url ( url -- url' )
159 : relative-url? ( url -- ? ) protocol>> not ;
161 ! Half-baked stuff follows
162 : secure-protocol? ( protocol -- ? )
167 GENERIC: >secure-addr ( addrspec -- addrspec' )
171 : url-addr ( url -- addr )
175 [ protocol>> protocol-port ]
178 secure-protocol? [ >secure-addr ] when ;
180 : ensure-port ( url -- url' )
181 clone dup protocol>> '[ _ protocol-port or ] change-port ;
184 SYNTAX: URL" lexer get skip-blank parse-string >url parsed ;
186 USING: vocabs vocabs.loader ;
188 "prettyprint" vocab [
189 "urls.prettyprint" require