Since ip4/ip6 services can run on different ports, we must include which version of ip we're using instead of just a port. Make URL objects store an inet4/i nt6/inet object with host/port slots instead of storing host/port slots separately. Stricter error checking on inet4/inet6 tuple creation. Update lots of code related to the URL change.
Doug Coleman
parent
676f6b6e06
commit
32f447d796
|
|
@ -16,7 +16,7 @@ CONSTANT: test-ip "127.0.0.1"
|
|||
: test-node-client ( -- addrspec )
|
||||
{
|
||||
{ [ os unix? ] [ "distributed-concurrency-test" temp-file <local> ] }
|
||||
{ [ os windows? ] [ test-ip insecure-port <inet4> ] }
|
||||
{ [ os windows? ] [ insecure-addr ] }
|
||||
} cond ;
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -61,7 +61,7 @@ ERROR: ftp-error got expected ;
|
|||
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
|
||||
|
|
@ -84,7 +84,7 @@ ERROR: ftp-error got expected ;
|
|||
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
|
||||
|
|
|
|||
|
|
@ -17,11 +17,9 @@ CONSTANT: test-file-contents "Files are so boring anymore."
|
|||
'[
|
||||
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
|
||||
|
|
|
|||
|
|
@ -96,7 +96,7 @@ CONSTANT: nested-forms-key "__n"
|
|||
: 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 ;
|
||||
|
|
@ -105,9 +105,7 @@ CONSTANT: nested-forms-key "__n"
|
|||
dup [
|
||||
url get [
|
||||
[ protocol>> ]
|
||||
[ host>> ]
|
||||
[ port>> remap-port ]
|
||||
tri 3array
|
||||
[ addr>> remap-addr ] bi 2array
|
||||
] bi@ =
|
||||
] when ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
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
|
||||
|
|
@ -12,7 +12,7 @@ IN: http.client.tests
|
|||
|
||||
[
|
||||
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{ } }
|
||||
|
|
@ -26,7 +26,7 @@ IN: http.client.tests
|
|||
|
||||
[
|
||||
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{ } }
|
||||
|
|
|
|||
|
|
@ -24,13 +24,13 @@ ERROR: too-many-redirects ;
|
|||
|
||||
: 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 )
|
||||
|
|
@ -41,7 +41,7 @@ ERROR: too-many-redirects ;
|
|||
|
||||
: 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 ;
|
||||
|
|
|
|||
|
|
@ -17,11 +17,11 @@ IN: http.tests
|
|||
[ "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 ;
|
||||
|
||||
|
|
@ -37,7 +37,7 @@ blah
|
|||
|
||||
[
|
||||
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" } } }
|
||||
|
|
@ -76,7 +76,7 @@ Host: www.sex.com
|
|||
|
||||
[
|
||||
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" } } }
|
||||
|
|
@ -97,7 +97,7 @@ Host: www.sex.com:101
|
|||
|
||||
[
|
||||
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" } } }
|
||||
|
|
@ -232,14 +232,14 @@ test-db [
|
|||
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= ;
|
||||
|
||||
[ ] [
|
||||
|
|
@ -257,14 +257,14 @@ test-db [
|
|||
|
||||
[ 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
|
||||
|
|
@ -278,10 +278,9 @@ test-db [
|
|||
] 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
|
||||
|
|
@ -305,12 +304,12 @@ test-db [
|
|||
: 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>
|
||||
|
|
@ -324,9 +323,9 @@ test-db [
|
|||
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
|
||||
|
|
@ -356,7 +355,7 @@ SYMBOL: a
|
|||
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
|
||||
|
|
@ -364,10 +363,10 @@ SYMBOL: a
|
|||
[ "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
|
||||
|
|
@ -376,15 +375,15 @@ SYMBOL: a
|
|||
[ "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
|
||||
|
|
@ -402,7 +401,7 @@ SYMBOL: a
|
|||
] 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
|
||||
|
||||
|
|
@ -424,12 +423,12 @@ SYMBOL: a
|
|||
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
|
||||
|
||||
|
|
@ -443,6 +442,6 @@ SYMBOL: a
|
|||
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
|
||||
|
|
|
|||
|
|
@ -1,12 +1,12 @@
|
|||
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
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ $nl
|
|||
{ $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"
|
||||
|
|
|
|||
|
|
@ -5,8 +5,8 @@ IN: 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 ;
|
||||
|
|
|
|||
|
|
@ -82,8 +82,7 @@ upload-limit [ 200,000,000 ] initialize
|
|||
] 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 )
|
||||
|
|
@ -116,7 +115,7 @@ GENERIC: write-full-response ( request response -- )
|
|||
|
||||
: ensure-domain ( cookie -- cookie )
|
||||
[
|
||||
url get host>> dup "localhost" =
|
||||
url get addr>> host>> dup "localhost" =
|
||||
[ drop ] [ or ] if
|
||||
] change-domain ;
|
||||
|
||||
|
|
@ -251,13 +250,12 @@ SYMBOL: params
|
|||
[
|
||||
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 )
|
||||
'[
|
||||
|
|
|
|||
|
|
@ -76,8 +76,8 @@ ARTICLE: "io.servers" "Threaded servers"
|
|||
"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 } "." ;
|
||||
|
|
@ -125,12 +125,12 @@ HELP: with-threaded-server
|
|||
}
|
||||
{ $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." } ;
|
||||
|
|
|
|||
|
|
@ -34,7 +34,7 @@ IN: io.servers
|
|||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -219,23 +219,13 @@ PRIVATE>
|
|||
[ ] cleanup
|
||||
] call ; inline
|
||||
|
||||
<PRIVATE
|
||||
: secure-addr ( -- inet/f )
|
||||
threaded-server get servers>>
|
||||
[ addr>> ] map [ secure? ] filter random ;
|
||||
|
||||
: 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 ;
|
||||
|
||||
: 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 ]
|
||||
|
|
|
|||
|
|
@ -118,10 +118,10 @@ HELP: inet
|
|||
|
||||
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>" }
|
||||
|
|
@ -129,10 +129,10 @@ HELP: 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>" }
|
||||
|
|
@ -140,7 +140,7 @@ HELP: 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" } }
|
||||
|
|
|
|||
|
|
@ -1,8 +1,17 @@
|
|||
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
|
||||
|
|
@ -25,6 +34,8 @@ io.streams.string ;
|
|||
[ 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
|
||||
|
||||
|
|
@ -132,3 +143,4 @@ io.streams.string ;
|
|||
|
||||
! Binding to all interfaces should work
|
||||
[ ] [ f 0 <inet4> <datagram> dispose ] unit-test
|
||||
[ ] [ f 0 <inet6> <datagram> dispose ] unit-test
|
||||
|
|
|
|||
|
|
@ -37,8 +37,6 @@ GENERIC: inet-ntop ( data addrspec -- str )
|
|||
|
||||
GENERIC: inet-pton ( str addrspec -- data )
|
||||
|
||||
GENERIC# with-port 1 ( addrspec port -- addrspec )
|
||||
|
||||
: make-sockaddr/size ( addrspec -- sockaddr size )
|
||||
[ make-sockaddr ] [ sockaddr-size ] bi ;
|
||||
|
||||
|
|
@ -55,6 +53,8 @@ HOOK: addrspec-of-family os ( af -- addrspec )
|
|||
|
||||
PRIVATE>
|
||||
|
||||
GENERIC# with-port 1 ( addrspec port -- addrspec )
|
||||
|
||||
TUPLE: local { path read-only } ;
|
||||
|
||||
: <local> ( path -- addrspec )
|
||||
|
|
@ -113,7 +113,18 @@ M: ipv4 parse-sockaddr ( sockaddr-in addrspec -- newaddrspec )
|
|||
|
||||
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> ;
|
||||
|
||||
|
|
@ -165,11 +176,13 @@ ERROR: more-than-8-components ;
|
|||
|
||||
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 ;
|
||||
|
||||
|
|
@ -192,7 +205,15 @@ M: ipv6 parse-sockaddr
|
|||
|
||||
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> ;
|
||||
|
||||
|
|
@ -365,7 +386,14 @@ TUPLE: inet < hostname port ;
|
|||
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*>
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@ HELP: >url
|
|||
"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:"
|
||||
|
|
@ -41,7 +41,7 @@ HELP: URL"
|
|||
{ $examples
|
||||
{ $example
|
||||
"USING: accessors prettyprint urls ;"
|
||||
"URL\" http://factorcode.org:80\" port>> ."
|
||||
"URL\" http://factorcode.org:80\" addr>> port>> ."
|
||||
"80"
|
||||
}
|
||||
} ;
|
||||
|
|
@ -70,13 +70,13 @@ HELP: ensure-port
|
|||
{ $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
|
||||
|
|
|
|||
|
|
@ -1,14 +1,13 @@
|
|||
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" }
|
||||
|
|
@ -18,7 +17,7 @@ CONSTANT: urls
|
|||
{
|
||||
T{ url
|
||||
{ protocol "http" }
|
||||
{ host "www.apple.com" }
|
||||
{ addr T{ inet f "www.apple.com" } }
|
||||
{ path "/a/path" }
|
||||
{ query H{ { "a" "b" } } }
|
||||
{ anchor "foo" }
|
||||
|
|
@ -28,8 +27,7 @@ CONSTANT: urls
|
|||
{
|
||||
T{ url
|
||||
{ protocol "http" }
|
||||
{ host "www.apple.com" }
|
||||
{ port 1234 }
|
||||
{ addr T{ inet f "www.apple.com" 1234 } }
|
||||
{ path "/another/fine/path" }
|
||||
{ anchor "foo" }
|
||||
}
|
||||
|
|
@ -64,7 +62,7 @@ CONSTANT: urls
|
|||
{
|
||||
T{ url
|
||||
{ protocol "ftp" }
|
||||
{ host "ftp.kernel.org" }
|
||||
{ addr T{ inet f "ftp.kernel.org" } }
|
||||
{ username "slava" }
|
||||
{ path "/" }
|
||||
}
|
||||
|
|
@ -73,7 +71,7 @@ CONSTANT: urls
|
|||
{
|
||||
T{ url
|
||||
{ protocol "ftp" }
|
||||
{ host "ftp.kernel.org" }
|
||||
{ addr T{ inet f "ftp.kernel.org" } }
|
||||
{ username "slava" }
|
||||
{ password "secret" }
|
||||
{ path "/" }
|
||||
|
|
@ -83,7 +81,7 @@ CONSTANT: urls
|
|||
{
|
||||
T{ url
|
||||
{ protocol "http" }
|
||||
{ host "foo.com" }
|
||||
{ addr T{ inet f "foo.com" } }
|
||||
{ path "/" }
|
||||
{ query H{ { "a" f } } }
|
||||
}
|
||||
|
|
@ -114,15 +112,13 @@ urls [
|
|||
[
|
||||
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" }
|
||||
}
|
||||
|
||||
|
|
@ -136,8 +132,7 @@ urls [
|
|||
[
|
||||
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" }
|
||||
|
|
@ -145,8 +140,7 @@ urls [
|
|||
] [
|
||||
T{ url
|
||||
{ protocol "http" }
|
||||
{ host "www.apple.com" }
|
||||
{ port 1234 }
|
||||
{ addr T{ inet f "www.apple.com" 1234 } }
|
||||
{ path "/a/path/" }
|
||||
}
|
||||
|
||||
|
|
@ -162,8 +156,7 @@ urls [
|
|||
[
|
||||
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" }
|
||||
|
|
@ -171,8 +164,7 @@ urls [
|
|||
] [
|
||||
T{ url
|
||||
{ protocol "http" }
|
||||
{ host "www.apple.com" }
|
||||
{ port 1234 }
|
||||
{ addr T{ inet f "www.apple.com" 1234 } }
|
||||
{ path "/a/path/" }
|
||||
}
|
||||
|
||||
|
|
@ -188,13 +180,13 @@ urls [
|
|||
[
|
||||
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" }
|
||||
}
|
||||
|
||||
|
|
@ -218,7 +210,7 @@ urls [
|
|||
[
|
||||
T{ url
|
||||
{ protocol "http" }
|
||||
{ host "localhost" }
|
||||
{ addr T{ inet f "localhost" } }
|
||||
{ query H{ { "foo" "bar" } } }
|
||||
{ path "/" }
|
||||
}
|
||||
|
|
@ -228,7 +220,7 @@ urls [
|
|||
[
|
||||
T{ url
|
||||
{ protocol "http" }
|
||||
{ host "localhost" }
|
||||
{ addr T{ inet f "localhost" } }
|
||||
{ query H{ { "foo" "bar" } } }
|
||||
{ path "/" }
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,13 +1,13 @@
|
|||
! 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 ;
|
||||
|
||||
|
|
@ -24,14 +24,12 @@ TUPLE: url protocol username password host port path query anchor ;
|
|||
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 )
|
||||
|
|
@ -68,23 +66,33 @@ url = ((protocol "://") => [[ first ]] auth hostname)?
|
|||
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 )
|
||||
{
|
||||
|
|
@ -102,7 +110,9 @@ M: string >url
|
|||
] [ 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 -- )
|
||||
|
|
@ -110,7 +120,7 @@ M: string >url
|
|||
"://" %
|
||||
{
|
||||
[ unparse-username-password ]
|
||||
[ host>> url-encode % ]
|
||||
[ addr>> host>> url-encode % ]
|
||||
[ url-port [ ":" % # ] when* ]
|
||||
[ path>> "/" head? [ "/" % ] unless ]
|
||||
} cleave ;
|
||||
|
|
@ -143,8 +153,7 @@ PRIVATE>
|
|||
[ [ 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 ]
|
||||
|
|
@ -153,8 +162,7 @@ PRIVATE>
|
|||
: relative-url ( url -- url' )
|
||||
clone
|
||||
f >>protocol
|
||||
f >>host
|
||||
f >>port ;
|
||||
f >>addr ;
|
||||
|
||||
: relative-url? ( url -- ? ) protocol>> not ;
|
||||
|
||||
|
|
@ -170,15 +178,15 @@ PRIVATE>
|
|||
|
||||
: 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! ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue