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 a5234f2c9cde3a1c7e098c61317c93035b22c58d..c3aa3a93ec32273840e6755bb6fb192687f7f714 100644 (file)
--- a/basis/urls/urls.factor
+++ b/basis/urls/urls.factor
@@ -2,9 +2,9 @@
 ! See http://factorcode.org/license.txt for BSD license.
 
 USING: accessors ascii assocs combinators
-combinators.short-circuit fry io.pathnames io.sockets
-io.sockets.secure kernel lexer linked-assocs make math
-math.parser multiline namespaces peg.ebnf present sequences
+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 ;
 
@@ -44,12 +44,26 @@ 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 ]]
@@ -62,8 +76,8 @@ host     = (ipv6 | hostname) (":"~ port?)?
 url      = (protocol ":"~)?
            ("//"~ auth? host?)?
            path?
-           ("?"~ query)?
-           ("#"~ anchor)?
+           ("?"~ query?)?
+           ("#"~ anchor?)?
 
 ]=]
 
@@ -97,7 +111,7 @@ 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 )
@@ -106,7 +120,7 @@ M: pathname >url string>> >url ;
 
 : ipv6-host ( host -- host/ipv6 ipv6? )
     dup { [ "[" head? ] [ "]" tail? ] } 1&& [
-        1 swap [ length 1 - ] [ subseq ] bi t
+        1 swap index-of-last subseq t
     ] [ f ] if ;
 
 : unparse-host ( url -- host )
@@ -127,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
@@ -145,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