basis: use lint.vocabs tool to trim using lists

[factor.git] / basis / urls / urls.factor

diff --git a/basis/urls/urls.factor b/basis/urls/urls.factor
index 37f8c1e597b2c02f636ab3b7bbde6004c2b40eb2..c3aa3a93ec32273840e6755bb6fb192687f7f714 100644 (file)
--- a/basis/urls/urls.factor
+++ b/basis/urls/urls.factor
@@ -1,9 +1,10 @@
 ! Copyright (C) 2008, 2011 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 
-USING: accessors ascii assocs combinators fry io.pathnames
-io.sockets io.sockets.secure kernel lexer linked-assocs make
-math.parser multiline namespaces peg.ebnf present sequences
+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 ;
 
@@ -25,10 +26,10 @@ TUPLE: url protocol username password host port path query anchor ;
 : set-query-params ( url params -- url )
     [ swap set-query-param ] assoc-each ;
 
-ERROR: malformed-port ;
+ERROR: malformed-port string ;
 
 : parse-port ( string -- port/f )
-    [ f ] [ string>number [ malformed-port ] unless* ] if-empty ;
+    [ f ] [ dup string>number [ ] [ malformed-port ] ?if ] if-empty ;
 
 : parse-host ( string -- host/f port/f )
     [
@@ -43,25 +44,40 @@ M: url >url ;
 
 <PRIVATE
 
+: 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     = [^#?]+          => [[ 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     = hostname (":"~ port?)?
+host     = (ipv6 | hostname) (":"~ port?)?
 
 url      = (protocol ":"~)?
            ("//"~ auth? host?)?
            path?
-           ("?"~ query)?
-           ("#"~ anchor)?
+           ("?"~ query?)?
+           ("#"~ anchor?)?
 
 ]=]
 
@@ -95,17 +111,25 @@ M: pathname >url string>> >url ;
 
 : unparse-username-password ( url -- )
     dup username>> dup [
-        % password>> [ ":" % % ] when* "@" %
+        url-encode % password>> [ ":" % url-encode % ] when* "@" %
     ] [ 2drop ] if ;
 
 : url-port ( url -- port/f )
     [ port>> ] [ protocol>> protocol-port ] bi over =
     [ drop f ] when ;
 
+: 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 ;
@@ -117,12 +141,17 @@ M: pathname >url string>> >url ;
 : 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
     [
         {
             [ unparse-protocol ]
             [ unparse-authority ]
-            [ path>> url-encode % ]
+            [ unparse-path ]
             [ query>> dup assoc-empty? [ drop ] [ "?" % assoc>query % ] if ]
             [ anchor>> [ "#" % present url-encode % ] when* ]
         } cleave
@@ -135,9 +164,9 @@ PRIVATE>
         { [ dup "/" head? ] [ nip ] }
         { [ dup empty? ] [ drop ] }
         { [ over "/" tail? ] [ append ] }
-        { [ "/" pick subseq-start not ] [ nip ] }
+        { [ over "/" subseq-index not ] [ nip ] }
         [ [ "/" split1-last drop "/" ] dip 3append ]
-    } cond ;
+    } cond remove-dot-segments ;
 
 <PRIVATE
 
@@ -170,17 +199,18 @@ PRIVATE>
 
 : url-addr ( url -- addr )
     [
-        [ host>> ]
+        [ host>> ipv6-host drop ]
         [ port>> ]
         [ protocol>> protocol-port ]
         tri or <inet>
     ] [
         dup protocol>> secure-protocol?
-        [ host>> <secure> ] [ drop ] if
+        [ host>> ipv6-host drop <secure> ] [ drop ] if
     ] bi ;
 
 : set-url-addr ( url addr -- url )
-    [ host>> >>host ] [ port>> >>port ] bi ;
+    [ [ host>> ] [ inet6? ] bi [ "[" "]" surround ] when >>host ]
+    [ port>> >>port ] bi ;
 
 : ensure-port ( url -- url' )
     clone dup protocol>> '[ _ protocol-port or ] change-port ;