! See http://factorcode.org/license.txt for BSD license.
USING: accessors ascii assocs combinators
-combinators.short-circuit fry io.encodings.string
-io.encodings.utf8 io.pathnames io.sockets io.sockets.secure
-kernel lexer linked-assocs make math math.parser multiline
-namespaces peg.ebnf present sequences sequences.generalizations
-splitting strings strings.parser urls.encoding vocabs.loader ;
+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 ;
IN: urls
<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 ;
+ "/" split [ url-decode "/" "%2F" replace ] map "/" join
+ remove-dot-segments ;
EBNF: parse-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 )
} cleave
] "" make ;
-: remove-dot-segments ( path -- path' )
- "/./" "/" replace
- [ "/../" split1 ] [ [ "/" split1-last drop ] dip "/" glue ] while*
- "/.." ?tail [ "/" split1-last drop "/" append ] when
- "../" ?head [ "/" prepend ] when
- "./" ?head [ "/" prepend ] when
- "/." ?tail [ "/" append ] when
- [ "/" ] when-empty ;
-
PRIVATE>
: url-append-path ( path1 path2 -- path )
{ [ 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 remove-dot-segments ;