: test-node-client ( -- addrspec )
{
{ [ os unix? ] [ "distributed-concurrency-test" temp-file <local> ] }
- { [ os windows? ] [ test-ip insecure-port <inet4> ] }
+ { [ os windows? ] [ insecure-addr ] }
} cond ;
strings>> first "|" split 2 tail* first string>number ;
: open-passive-client ( url protocol -- stream )
- [ host>> ftp-epsv parse-epsv <inet> ] dip <client> drop ;
+ [ addr>> ftp-epsv parse-epsv with-port ] dip <client> drop ;
: list ( url -- ftp-response )
utf8 open-passive-client
ftp-set-binary 200 ftp-assert ;
: ftp-connect ( url -- stream )
- [ host>> ] [ port>> ] bi <inet> utf8 <client> drop ;
+ addr>> utf8 <client> drop ;
: with-ftp-client ( url quot -- )
[ [ ftp-connect ] keep ] dip
'[
current-temporary-directory get
0 <ftp-server> [
- insecure-port
- <url>
- swap >>port
+ insecure-addr
+ >url
"ftp" >>protocol
- "localhost" >>host
create-test-file >>path
@
] with-threaded-server
: referrer ( -- referrer/f )
#! Typo is intentional, it's in the HTTP spec!
"referer" request get header>> at
- dup [ >url ensure-port [ remap-port ] change-port ] when ;
+ dup [ >url ensure-port [ remap-addr ] change-addr ] when ;
: user-agent ( -- user-agent )
"user-agent" request get header>> at "" or ;
dup [
url get [
[ protocol>> ]
- [ host>> ]
- [ port>> remap-port ]
- tri 3array
+ [ addr>> remap-addr ] bi 2array
] bi@ =
] when ;
USING: http.client http.client.private http tools.test
-namespaces urls ;
+namespaces urls io.sockets ;
IN: http.client.tests
[ "localhost" f ] [ "localhost" parse-host ] unit-test
[
T{ request
- { url T{ url { protocol "http" } { host "www.apple.com" } { port 80 } { path "/index.html" } } }
+ { url T{ url { protocol "http" } { addr T{ inet f "www.apple.com" 80 } } { path "/index.html" } } }
{ method "GET" }
{ version "1.1" }
{ cookies V{ } }
[
T{ request
- { url T{ url { protocol "https" } { host "www.amazon.com" } { port 443 } { path "/index.html" } } }
+ { url T{ url { protocol "https" } { addr T{ inet f "www.amazon.com" 443 } } { path "/index.html" } } }
{ method "GET" }
{ version "1.1" }
{ cookies V{ } }
: default-port? ( url -- ? )
{
- [ port>> not ]
- [ [ port>> ] [ protocol>> protocol-port ] bi = ]
+ [ addr>> port>> not ]
+ [ [ addr>> port>> ] [ protocol>> protocol-port ] bi = ]
} 1|| ;
: unparse-host ( url -- string )
- dup default-port? [ host>> ] [
- [ host>> ] [ port>> number>string ] bi ":" glue
+ dup default-port? [ addr>> host>> ] [
+ [ addr>> host>> ] [ addr>> port>> number>string ] bi ":" glue
] if ;
: set-host-header ( request header -- request header )
: write-request-header ( request -- request )
dup header>> >hashtable
- over url>> host>> [ set-host-header ] when
+ over url>> addr>> host>> [ set-host-header ] when
over post-data>> [ set-post-data-headers ] when*
over cookies>> [ set-cookie-header ] unless-empty
write-header ;
[ "localhost" f ] [ "localhost" parse-host ] unit-test
[ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test
-[ "localhost" ] [ T{ url { protocol "http" } { host "localhost" } } unparse-host ] unit-test
-[ "localhost" ] [ T{ url { protocol "http" } { host "localhost" } { port 80 } } unparse-host ] unit-test
-[ "localhost" ] [ T{ url { protocol "https" } { host "localhost" } { port 443 } } unparse-host ] unit-test
-[ "localhost:8080" ] [ T{ url { protocol "http" } { host "localhost" } { port 8080 } } unparse-host ] unit-test
-[ "localhost:8443" ] [ T{ url { protocol "https" } { host "localhost" } { port 8443 } } unparse-host ] unit-test
+[ "localhost" ] [ T{ url { protocol "http" } { addr T{ inet f "localhost" } } } unparse-host ] unit-test
+[ "localhost" ] [ T{ url { protocol "http" } { addr T{ inet f "localhost" 80 } } } unparse-host ] unit-test
+[ "localhost" ] [ T{ url { protocol "https" } { addr T{ inet f "localhost" 443 } } } unparse-host ] unit-test
+[ "localhost:8080" ] [ T{ url { protocol "http" } { addr T{ inet f "localhost" 8080 } } } unparse-host ] unit-test
+[ "localhost:8443" ] [ T{ url { protocol "https" } { addr T{ inet f "localhost" 8443 } } } unparse-host ] unit-test
: lf>crlf ( string -- string' ) "\n" split "\r\n" join ;
[
T{ request
- { url T{ url { path "/bar" } } }
+ { url T{ url { path "/bar" } { addr T{ inet } } } }
{ method "POST" }
{ version "1.1" }
{ header H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } } }
[
T{ request
- { url T{ url { host "www.sex.com" } { path "/bar" } } }
+ { url T{ url { addr T{ inet f "www.sex.com" } } { path "/bar" } } }
{ method "HEAD" }
{ version "1.1" }
{ header H{ { "host" "www.sex.com" } } }
[
T{ request
- { url T{ url { host "www.sex.com" } { port 101 } { path "/bar" } } }
+ { url T{ url { addr T{ inet f "www.sex.com" 101 } } { path "/bar" } } }
{ method "HEAD" }
{ version "1.1" }
{ header H{ { "host" "www.sex.com:101" } } }
0 >>insecure
f >>secure
start-server
- servers>> random addr>> port>>
- ] with-scope "port" set ;
+ servers>> random addr>>
+ ] with-scope "addr" set ;
-: add-port ( url -- url' )
- >url clone "port" get >>port ;
+: add-addr ( url -- url' )
+ >url clone "addr" get >>addr ;
: stop-test-httpd ( -- )
- "http://localhost/quit" add-port http-get nip
+ "http://localhost/quit" add-addr http-get nip
"Goodbye" assert= ;
[ ] [
[ t ] [
"vocab:http/test/foo.html" ascii file-contents
- "http://localhost/nested/foo.html" add-port http-get nip =
+ "http://localhost/nested/foo.html" add-addr http-get nip =
] unit-test
-[ "http://localhost/redirect-loop" add-port http-get nip ]
+[ "http://localhost/redirect-loop" add-addr http-get nip ]
[ too-many-redirects? ] must-fail-with
[ "Goodbye" ] [
- "http://localhost/quit" add-port http-get nip
+ "http://localhost/quit" add-addr http-get nip
] unit-test
! HTTP client redirect bug
] unit-test
[ "Goodbye" ] [
- "http://localhost/redirect" add-port http-get nip
+ "http://localhost/redirect" add-addr http-get nip
] unit-test
-
[ ] [
[ stop-test-httpd ] ignore-errors
] unit-test
: 404? ( response -- ? ) [ download-failed? ] [ response>> code>> 404 = ] bi and ;
! This should give a 404 not an infinite redirect loop
-[ "http://localhost/d/blah" add-port http-get nip ] [ 404? ] must-fail-with
+[ "http://localhost/d/blah" add-addr http-get nip ] [ 404? ] must-fail-with
! This should give a 404 not an infinite redirect loop
-[ "http://localhost/blah/" add-port http-get nip ] [ 404? ] must-fail-with
+[ "http://localhost/blah/" add-addr http-get nip ] [ 404? ] must-fail-with
-[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test
+[ "Goodbye" ] [ "http://localhost/quit" add-addr http-get nip ] unit-test
[ ] [
<dispatcher>
test-httpd
] unit-test
-[ "Hi" ] [ "http://localhost/" add-port http-get nip ] unit-test
+[ "Hi" ] [ "http://localhost/" add-addr http-get nip ] unit-test
-[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test
+[ "Goodbye" ] [ "http://localhost/quit" add-addr http-get nip ] unit-test
USING: html.components html.forms
xml xml.traversal validators
string>xml body>> "input" deep-tag-named "value" attr ;
[ "3" ] [
- "http://localhost/" add-port http-get
+ "http://localhost/" add-addr http-get
swap dup cookies>> "cookies" set session-id-key get-cookie
value>> "session-id" set test-a
] unit-test
[ "4" ] [
[
"4" "a" set
- "http://localhost" add-port "__u" set
+ "http://localhost" add-addr "__u" set
"session-id" get session-id-key set
] H{ } make-assoc
- "http://localhost/" add-
port <post-request> "cookies" get >>cookies http-request nip test-a
+ "http://localhost/" add-
addr <post-request> "cookies" get >>cookies http-request nip test-a
] unit-test
[ 4 ] [ a get-global ] unit-test
[ "xyz" ] [
[
"xyz" "a" set
- "http://localhost" add-port "__u" set
+ "http://localhost" add-addr "__u" set
"session-id" get session-id-key set
] H{ } make-assoc
- "http://localhost/" add-
port <post-request> "cookies" get >>cookies http-request nip test-a
+ "http://localhost/" add-
addr <post-request> "cookies" get >>cookies http-request nip test-a
] unit-test
[ 4 ] [ a get-global ] unit-test
-[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test
+[ "Goodbye" ] [ "http://localhost/quit" add-addr http-get nip ] unit-test
! Test cloning
[ f ] [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test
] unit-test
[ t ] [
- "http://localhost/" add-port http-get nip
+ "http://localhost/" add-addr http-get nip
"vocab:http/test/foo.html" ascii file-contents =
] unit-test
test-httpd
] unit-test
-[ "OK" ] [ "data" "http://localhost/a" add-port http-post nip ] unit-test
+[ "OK" ] [ "data" "http://localhost/a" add-addr http-post nip ] unit-test
! Check that download throws errors (reported by Chris Double)
[
"resource:temp" [
- "http://localhost/tweet_my_twat" add-port download
+ "http://localhost/tweet_my_twat" add-addr download
] with-directory
] must-fail
test-httpd
] unit-test
-[ "OK\n\n" ] [ "http://localhost/" add-port http-get nip ] unit-test
+[ "OK\n\n" ] [ "http://localhost/" add-addr http-get nip ] unit-test
[ ] [ stop-test-httpd ] unit-test
-USING: http http.server.redirection urls accessors
-namespaces tools.test present kernel ;
+USING: accessors http http.server.redirection io.sockets kernel
+namespaces present tools.test urls ;
IN: http.server.redirection.tests
[
<request>
<url>
"http" >>protocol
- "www.apple.com" >>host
+ T{ inet f "www.apple.com" } >>addr
"/xxx/bar" >>path
{ { "a" "b" } } >>query
dup url set
{ $subsections port-remapping }
"For example, with the above setup, we would set it as follows:"
{ $code
- "{ { 8080 80 } { 8443 443 } } port-remapping set-global"
+ "{ { T{ inet4 f f 8080 } T{ inet4 f f 80 } } { T{ inet4 f f 8443 } T{ inet4 f f 443 } } } port-remapping set-global"
} ;
ABOUT: "http.server.remapping"
SYMBOL: port-remapping
-: remap-port ( n -- n' )
+: remap-addr ( addr -- addr' )
[ port-remapping get at ] keep or ;
-: secure-http-port ( -- n )
- secure-port remap-port ;
+: secure-http-port ( -- addr )
+ secure-addr remap-addr ;
] when ;
: extract-host ( request -- request )
- [ ] [ url>> ] [ "host" header parse-host ] tri
- [ >>host ] [ >>port ] bi*
+ [ ] [ url>> ] [ "host" header parse-host <inet> >>addr ] tri
drop ;
: extract-cookies ( request -- request )
: ensure-domain ( cookie -- cookie )
[
- url get host>> dup "localhost" =
+ url get addr>> host>> dup "localhost" =
[ drop ] [ or ] if
] change-domain ;
[
local-address get
[ secure? "https" "http" ? >>protocol ]
- [ port>> remap-port '[ _ or ] change-port ]
- bi
+ [ remap-addr '[ _ or ] change-addr ] bi
] change-url drop ;
: valid-request? ( request -- ? )
- url>> port>> remap-port
- local-address get port>> remap-port = ;
+ url>> addr>> remap-addr
+ local-address get remap-addr = ;
: do-request ( request -- response )
'[
"From within the dynamic scope of a client handler, several words can be used to interact with the threaded server:"
{ $subsections
stop-this-server
- secure-port
- insecure-port
+ secure-addr
+ insecure-addr
}
"Additionally, the " { $link local-address } " and "
{ $subsections remote-address } " variables are set, as in " { $link with-client } "." ;
}
{ $description "Runs a server and calls a quotation, stopping the server once the quotation returns." } ;
-HELP: secure-port
-{ $values { "n/f" { $maybe integer } } }
+HELP: secure-addr
+{ $values { "inet/f" { $maybe inet } } }
{ $description "Outputs one of the port numbers on which the current threaded server accepts secure socket connections. Outputs " { $link f } " if the current threaded server does not accept secure socket connections." }
{ $notes "Can only be used from the dynamic scope of a " { $link handle-client* } " call." } ;
-HELP: insecure-port
-{ $values { "n/f" { $maybe integer } } }
+HELP: insecure-addr
+{ $values { "inet/f" { $maybe inet } } }
{ $description "Outputs one of the port numbers on which the current threaded server accepts ordinary socket connections. Outputs " { $link f } " if the current threaded server does not accept ordinary socket connections." }
{ $notes "Can only be used from the dynamic scope of a " { $link handle-client* } " call." } ;
0 >>insecure
[ "Hello world." write stop-this-server ] >>handler
[
- "localhost" insecure-port <inet> ascii <client> drop stream-contents
+ insecure-addr ascii <client> drop stream-contents
] with-threaded-server
] unit-test
[ ] cleanup
] call ; inline
-<PRIVATE
-
-: first-port ( quot -- n/f )
- [ threaded-server get servers>> ] dip
- filter [ f ] [ first addr>> port>> ] if-empty ; inline
-
-PRIVATE>
-
-: secure-port ( -- n/f ) [ addr>> secure? ] first-port ;
-
-: insecure-port ( -- n/f ) [ addr>> secure? not ] first-port ;
-
-: secure-addr ( -- inet )
- threaded-server get servers>> [ addr>> secure? ] filter random ;
+: secure-addr ( -- inet/f )
+ threaded-server get servers>>
+ [ addr>> ] map [ secure? ] filter random ;
-: insecure-addr ( -- inet )
- threaded-server get servers>> [ addr>> secure? not ] filter random addr>> ;
+: insecure-addr ( -- inet/f )
+ threaded-server get servers>>
+ [ addr>> ] map [ secure? not ] filter random ;
: server. ( threaded-server -- )
[ [ "=== " write name>> ] [ ] bi write-object nl ]
HELP: <inet>
{ $values { "host" "a host name" } { "port" "a port number" } { "inet" inet } }
-{ $description "Creates a new " { $link inet } " address specifier." } ;
+{ $description "Creates a new " { $link inet } " address specifier. If the host is an IPv4 address, an " { $link inet4 } " tuple will be returned; likewise for " { $link inet6 } "." } ;
HELP: inet4
-{ $class-description "IPv4 address/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the IPv4 address and port number, respectively. New instances are created by calling " { $link <inet4> } "." }
+{ $class-description "IPv4 address/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the IPv4 address and port number, respectively. New instances are created by calling " { $link <inet4> } ". A host of " { $link f } " refers to localhost, and a port of " { $link f } " defers the port choice until later." }
{ $notes "Most applications do not operate on IPv4 addresses directly, and instead should use the " { $link inet } " address specifier, or call " { $link resolve-host } "." }
{ $examples
{ $code "\"127.0.0.1\" 8080 <inet4>" }
HELP: <inet4>
{ $values { "host" "an IPv4 address" } { "port" "a port number" } { "inet4" inet4 } }
-{ $description "Creates a new " { $link inet4 } " address specifier." } ;
+{ $description "Creates a new " { $link inet4 } " address specifier. A value of " { $link f } " as the host refers to localhost, while " { $link f } " as the port defers the port choice until a later time." } ;
HELP: inet6
-{ $class-description "IPv6 address/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the IPv6 address and port number, respectively. New instances are created by calling " { $link <inet6> } "." }
+{ $class-description "IPv6 address/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the IPv6 address and port number, respectively. New instances are created by calling " { $link <inet6> } ". A host of " { $link f } " refers to localhost, and a port of " { $link f } " defers the port choice until later." }
{ $notes "Most applications do not operate on IPv6 addresses directly, and instead should use the " { $link inet } " address specifier, or call " { $link resolve-host } "." }
{ $examples
{ $code "\"::1\" 8080 <inet6>" }
HELP: <inet6>
{ $values { "host" "an IPv6 address" } { "port" "a port number" } { "inet6" inet6 } }
-{ $description "Creates a new " { $link inet6 } " address specifier." } ;
+{ $description "Creates a new " { $link inet6 } " address specifier. A value of " { $link f } " as the host refers to localhost, while " { $link f } " as the port defers the port choice until a later time." } ;
HELP: <client>
{ $values { "remote" "an address specifier" } { "encoding" "an encding descriptor" } { "stream" "a bidirectional stream" } { "local" "an address specifier" } }
-IN: io.sockets.tests
USING: io.sockets io.sockets.private sequences math tools.test
namespaces accessors kernel destructors calendar io.timeouts
io.encodings.utf8 io concurrency.promises threads
io.streams.string ;
+IN: io.sockets.tests
+
+[ T{ inet4 f f 0 } ] [ f 0 <inet4> ] unit-test
+[ T{ inet6 f f 0 } ] [ f 0 <inet6> ] unit-test
+
+[ T{ inet f "google.com" f } ] [ "google.com" f <inet> ] unit-test
+
+[ T{ inet f "google.com" 0 } ] [ "google.com" 0 <inet> ] unit-test
+[ T{ inet4 f "8.8.8.8" 0 } ] [ "8.8.8.8" 0 <inet> ] unit-test
+[ T{ inet6 f "5:5:5:5:6:6:6:6" 0 } ] [ "5:5:5:5:6:6:6:6" 0 <inet> ] unit-test
[ B{ 1 2 3 4 } ]
[ "1.2.3.4" T{ inet4 } inet-pton ] unit-test
[ B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } ]
[ "::" T{ inet6 } inet-pton ] unit-test
+[ f T{ inet6 } inet-pton ] [ reason>> empty-ipv6? ] must-fail-with
+
[ "0:0:0:0:0:0:0:0" ]
[ B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } T{ inet6 } inet-ntop ] unit-test
! Binding to all interfaces should work
[ ] [ f 0 <inet4> <datagram> dispose ] unit-test
+[ ] [ f 0 <inet6> <datagram> dispose ] unit-test
GENERIC: inet-pton ( str addrspec -- data )
-GENERIC# with-port 1 ( addrspec port -- addrspec )
-
: make-sockaddr/size ( addrspec -- sockaddr size )
[ make-sockaddr ] [ sockaddr-size ] bi ;
PRIVATE>
+GENERIC# with-port 1 ( addrspec port -- addrspec )
+
TUPLE: local { path read-only } ;
: <local> ( path -- addrspec )
TUPLE: inet4 < ipv4 { port integer read-only } ;
-C: <inet4> inet4
+: inet-string? ( string exemplar -- ? )
+ '[ _ _ inet-pton drop t ] [ drop f ] recover ;
+
+: inet4-string? ( string -- ? ) T{ inet4 } inet-string? ;
+
+ERROR: invalid-inet4 string ;
+
+: ensure-inet4-string ( string -- string )
+ dup [ dup inet4-string? [ invalid-inet4 ] unless ] when ;
+
+: <inet4> ( host port -- inet4 )
+ [ ensure-inet4-string ] dip inet4 boa ;
M: ipv4 with-port [ host>> ] dip <inet4> ;
PRIVATE>
+ERROR: empty-ipv6 ;
+
M: ipv6 inet-pton ( str addrspec -- data )
- drop
- [ "::" split1 [ parse-ipv6 ] bi@ pad-ipv6 ipv6-bytes ]
- [ invalid-ipv6 ]
- recover ;
+ drop [
+ [ empty-ipv6 ]
+ [ "::" split1 [ parse-ipv6 ] bi@ pad-ipv6 ipv6-bytes ] if-empty
+ ] [ invalid-ipv6 ] recover ;
M: ipv6 address-size drop 16 ;
TUPLE: inet6 < ipv6 { port integer read-only } ;
-C: <inet6> inet6
+: inet6-string? ( string -- ? ) T{ inet6 } inet-string? ;
+
+ERROR: invalid-inet6 string ;
+
+: ensure-inet6-string ( string -- string )
+ dup [ dup inet6-string? [ invalid-inet6 ] unless ] when ;
+
+: <inet6> ( host port -- inet6 )
+ [ ensure-inet6-string ] dip inet6 boa ;
M: ipv6 with-port [ host>> ] dip <inet6> ;
M: inet present
[ host>> ] [ port>> number>string ] bi ":" glue ;
-C: <inet> inet
+: <inet> ( host port -- inet )
+ {
+ { [ over inet4-string? ] [ inet4 boa ] }
+ { [ over inet6-string? ] [ inet6 boa ] }
+ [ inet boa ]
+ } cond ;
+
+M: inet with-port [ host>> ] dip <inet> ;
M: string resolve-host
f prepare-addrinfo f <void*>
"We can examine the URL object:"
{ $example
"USING: accessors io urls ;"
- "\"http://www.apple.com\" >url host>> print"
+ "\"http://www.apple.com\" >url addr>> host>> print"
"www.apple.com"
}
"A relative URL does not have a protocol, host or port:"
{ $examples
{ $example
"USING: accessors prettyprint urls ;"
- "URL\" http://factorcode.org:80\" port>> ."
+ "URL\" http://factorcode.org:80\" addr>> port>> ."
"80"
}
} ;
{ $examples
{ $example
"USING: accessors prettyprint urls ;"
- "URL\" https://concatenative.org\" ensure-port port>> ."
+ "URL\" https://concatenative.org\" ensure-port addr>> port>> ."
"443"
}
} ;
HELP: parse-host
-{ $values { "string" string } { "host" string } { "port" { $maybe integer } } }
+{ $values { "string" string } { "host/f" string } { "port/f" { $maybe integer } } }
{ $description "Splits a string of the form " { $snippet "host:port" } " into a host and a port number. If the port number is not specified, outputs " { $link f } "." }
{ $notes "This word is used by " { $link >url } ". It can also be used directly to parse " { $snippet "host:port" } " strings which are not full URLs." }
{ $examples
+USING: accessors arrays assocs io.sockets kernel present
+prettyprint tools.test urls urls.private ;
IN: urls.tests
-USING: urls urls.private tools.test prettyprint
-arrays kernel assocs present accessors ;
CONSTANT: urls
{
{
T{ url
{ protocol "http" }
- { host "www.apple.com" }
- { port 1234 }
+ { addr T{ inet f "www.apple.com" 1234 } }
{ path "/a/path" }
{ query H{ { "a" "b" } } }
{ anchor "foo" }
{
T{ url
{ protocol "http" }
- { host "www.apple.com" }
+ { addr T{ inet f "www.apple.com" } }
{ path "/a/path" }
{ query H{ { "a" "b" } } }
{ anchor "foo" }
{
T{ url
{ protocol "http" }
- { host "www.apple.com" }
- { port 1234 }
+ { addr T{ inet f "www.apple.com" 1234 } }
{ path "/another/fine/path" }
{ anchor "foo" }
}
{
T{ url
{ protocol "ftp" }
- { host "ftp.kernel.org" }
+ { addr T{ inet f "ftp.kernel.org" } }
{ username "slava" }
{ path "/" }
}
{
T{ url
{ protocol "ftp" }
- { host "ftp.kernel.org" }
+ { addr T{ inet f "ftp.kernel.org" } }
{ username "slava" }
{ password "secret" }
{ path "/" }
{
T{ url
{ protocol "http" }
- { host "foo.com" }
+ { addr T{ inet f "foo.com" } }
{ path "/" }
{ query H{ { "a" f } } }
}
[
T{ url
{ protocol "http" }
- { host "www.apple.com" }
- { port 1234 }
+ { addr T{ inet f "www.apple.com" 1234 } }
{ path "/a/path" }
}
] [
T{ url
{ protocol "http" }
- { host "www.apple.com" }
- { port 1234 }
+ { addr T{ inet f "www.apple.com" 1234 } }
{ path "/foo" }
}
[
T{ url
{ protocol "http" }
- { host "www.apple.com" }
- { port 1234 }
+ { addr T{ inet f "www.apple.com" 1234 } }
{ path "/a/path/relative/path" }
{ query H{ { "a" "b" } } }
{ anchor "foo" }
] [
T{ url
{ protocol "http" }
- { host "www.apple.com" }
- { port 1234 }
+ { addr T{ inet f "www.apple.com" 1234 } }
{ path "/a/path/" }
}
[
T{ url
{ protocol "http" }
- { host "www.apple.com" }
- { port 1234 }
+ { addr T{ inet f "www.apple.com" 1234 } }
{ path "/a/path/relative/path" }
{ query H{ { "a" "b" } } }
{ anchor "foo" }
] [
T{ url
{ protocol "http" }
- { host "www.apple.com" }
- { port 1234 }
+ { addr T{ inet f "www.apple.com" 1234 } }
{ path "/a/path/" }
}
[
T{ url
{ protocol "http" }
- { host "www.apple.com" }
+ { addr T{ inet f "www.apple.com" } }
{ path "/xxx/baz" }
}
] [
T{ url
{ protocol "http" }
- { host "www.apple.com" }
+ { addr T{ inet f "www.apple.com" } }
{ path "/xxx/bar" }
}
[
T{ url
{ protocol "http" }
- { host "localhost" }
+ { addr T{ inet f "localhost" } }
{ query H{ { "foo" "bar" } } }
{ path "/" }
}
[
T{ url
{ protocol "http" }
- { host "localhost" }
+ { addr T{ inet f "localhost" } }
{ query H{ { "foo" "bar" } } }
{ path "/" }
}
[ "/" ] [ "http://www.jedit.org" >url path>> ] unit-test
-[ "USING: urls ;\nURL\" foo\"" ] [ URL" foo" unparse-use ] unit-test
\ No newline at end of file
+[ "USING: urls ;\nURL\" foo\"" ] [ URL" foo" unparse-use ] unit-test
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel ascii combinators combinators.short-circuit
-sequences splitting fry namespaces make assocs arrays strings
-io.sockets io.encodings.string io.encodings.utf8 math
-math.parser accessors parser strings.parser lexer
-hashtables present peg.ebnf urls.encoding ;
+USING: accessors arrays ascii assocs classes combinators
+combinators.short-circuit fry hashtables io.encodings.string
+io.encodings.utf8 io.sockets kernel lexer make math math.parser
+namespaces parser peg.ebnf present sequences splitting strings
+strings.parser urls.encoding ;
IN: urls
-TUPLE: url protocol username password host port path query anchor ;
+TUPLE: url protocol username password addr path query anchor ;
: <url> ( -- url ) url new ;
nip delete-query-param
] if ;
-: parse-host ( string -- host port )
+ERROR: malformed-port ;
+
+: parse-host ( string -- host/f port/f )
[
- ":" split1 [ url-decode ] [
- dup [
- string>number
- dup [ "Invalid port" throw ] unless
- ] when
- ] bi*
+ ":" split1-last [ url-decode ]
+ [ dup [ string>number [ malformed-port ] unless* ] when ] bi*
] [ f f ] if* ;
GENERIC: >url ( obj -- url )
PRIVATE>
M: string >url
+ [ <url> ] dip
parse-url {
[
first [
- [ first ] ! protocol
+ [ first >>protocol ]
[
second
- [ first [ first2 ] [ f f ] if* ] ! username, password
- [ second parse-host ] ! host, port
- bi
+ [ first [ first2 [ >>username ] [ >>password ] bi* ] when* ]
+ [ second parse-host <inet> >>addr ] bi
] bi
- ] [ f f f f f ] if*
+ ] when*
]
- [ second ] ! pathname
- [ third ] ! query
- [ fourth ] ! anchor
- } cleave url boa
- dup host>> [ [ "/" or ] change-path ] when ;
+ [ second >>path ]
+ [ third >>query ]
+ [ fourth >>anchor ]
+ } cleave
+ dup addr>> [ [ "/" or ] change-path ] when ;
+
+<PRIVATE
+
+: inet>url ( inet -- url ) [ <url> ] dip >>addr ;
+
+PRIVATE>
+
+M: inet >url inet>url ;
+M: inet4 >url inet>url ;
+M: inet6 >url inet>url ;
: protocol-port ( protocol -- port )
{
] [ 2drop ] if ;
: url-port ( url -- port/f )
- [ port>> ] [ port>> ] [ protocol>> protocol-port ] tri =
+ [ addr>> port>> ]
+ [ addr>> port>> ]
+ [ protocol>> protocol-port ] tri =
[ drop f ] when ;
: unparse-host-part ( url protocol -- )
"://" %
{
[ unparse-username-password ]
- [ host>> url-encode % ]
+ [ addr>> host>> url-encode % ]
[ url-port [ ":" % # ] when* ]
[ path>> "/" head? [ "/" % ] unless ]
} cleave ;
[ [ protocol>> ] either? >>protocol ]
[ [ username>> ] either? >>username ]
[ [ password>> ] either? >>password ]
- [ [ host>> ] either? >>host ]
- [ [ port>> ] either? >>port ]
+ [ [ addr>> ] either? >>addr ]
[ [ path>> ] bi@ swap url-append-path >>path ]
[ [ query>> ] either? >>query ]
[ [ anchor>> ] either? >>anchor ]
: relative-url ( url -- url' )
clone
f >>protocol
- f >>host
- f >>port ;
+ f >>addr ;
: relative-url? ( url -- ? ) protocol>> not ;
: url-addr ( url -- addr )
[
- [ host>> ]
- [ port>> ]
- [ protocol>> protocol-port ]
- tri or <inet>
+ [ addr>> ]
+ [ [ addr>> port>> ] [ protocol>> protocol-port ] bi or ] bi with-port
] [ protocol>> ] bi
secure-protocol? [ >secure-addr ] when ;
: ensure-port ( url -- url' )
- clone dup protocol>> '[ _ protocol-port or ] change-port ;
+ clone dup protocol>> '[
+ dup port>> _ protocol-port or with-port
+ ] change-addr ;
! Literal syntax
SYNTAX: URL" lexer get skip-blank parse-string >url suffix! ;
projects / factor.git / commitdiff