Skip to content
Open
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
41 changes: 41 additions & 0 deletions basis/urls/urls-tests.factor
Original file line number Diff line number Diff line change
Expand Up @@ -115,6 +115,33 @@ CONSTANT: urls {
}
"t1000://www.google.com/"
}
{
T{ url
{ protocol "no-auth" }
{ path "/some/random/path" }
}
"no-auth:/some/random/path"
}
{
T{ url
{ protocol "http" }
{ host "example.org" }
{ path "/" }
{ username "user" }
{ password "" }
}
"http://user:@example.org/"
}
{
T{ url
{ protocol "http" }
{ host "example.org" }
{ path "/" }
{ username "" }
{ password "pass" }
}
"http://:pass@example.org/"
}
}

urls [
Expand All @@ -125,6 +152,20 @@ urls [
swap [ 1array ] [ [ present ] curry ] bi* unit-test
] assoc-each

{ T{ url
{ protocol "https" }
{ host "www.google.com" }
{ path "/" }
} }
[ "https://www.google.com:/" >url ] unit-test

{ "https://www.google.com/" }
[ T{ url
{ protocol "https" }
{ host "www.google.com" }
{ path "/" }
} present ] unit-test

{ "b" } [ "a" "b" url-append-path ] unit-test

{ "a/b" } [ "a/c" "b" url-append-path ] unit-test
Expand Down
28 changes: 14 additions & 14 deletions basis/urls/urls.factor
Original file line number Diff line number Diff line change
Expand Up @@ -5,7 +5,7 @@ USING: accessors arrays ascii assocs combinators fry
io.pathnames io.sockets io.sockets.secure kernel lexer
linked-assocs make math.parser multiline namespaces peg.ebnf
present sequences splitting strings strings.parser urls.encoding
vocabs.loader ;
vocabs.loader math math.order ;

IN: urls

Expand All @@ -30,7 +30,10 @@ ERROR: malformed-port ;
: parse-host ( string -- host/f port/f )
[
":" split1-last [ url-decode ]
[ dup [ string>number [ malformed-port ] unless* ] when ] bi*
[ [ f ]
[ string>number [ malformed-port ] unless* ]
if-empty
] bi*
] [ f f ] if* ;

GENERIC: >url ( obj -- url )
Expand All @@ -44,8 +47,8 @@ M: url >url ;
EBNF: parse-url [=[

protocol = [a-zA-Z0-9.+-]+ => [[ url-decode ]]
username = [^/:@#?]+ => [[ url-decode ]]
password = [^/:@#?]+ => [[ url-decode ]]
username = [^/:@#?]* => [[ url-decode ]]
password = [^/:@#?]* => [[ url-decode ]]
pathname = [^#?]+ => [[ url-decode ]]
query = [^#]+ => [[ query>assoc ]]
anchor = .+ => [[ url-decode ]]
Expand All @@ -58,7 +61,8 @@ auth = (username (":" password => [[ second ]])? "@"
=> [[ first2 2array ]])?

url = (((protocol "://") => [[ first ]] auth hostname)
| (("//") => [[ f ]] auth hostname))?
| (("//") => [[ f ]] auth hostname)
| ((protocol ":") => [[ first V{ f f } V{ } 2sequence ]]))?
(pathname)?
("?" query => [[ second ]])?
("#" anchor => [[ second ]])?
Expand Down Expand Up @@ -117,20 +121,16 @@ M: pathname >url string>> >url ;

! URL" //foo.com" takes on the protocol of the url it's derived from
: unparse-protocol ( url -- )
dup protocol>> [
% "://" % unparse-host-part
] [
dup host>> [
"//" % unparse-host-part
] [
drop
] if
] if* ;
protocol>> [ % ":" % ] when* ;

: unparse-authority ( url -- )
dup host>> [ "//" % unparse-host-part ] [ drop ] if ;

M: url present
[
{
[ unparse-protocol ]
[ unparse-authority ]
[ path>> url-encode % ]
[ query>> dup assoc-empty? [ drop ] [ "?" % assoc>query % ] if ]
[ anchor>> [ "#" % present url-encode % ] when* ]
Expand Down