steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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.

db4
Doug Coleman 2010-10-03 03:39:30 -05:00
parent 676f6b6e06
commit 32f447d796
20 changed files with 192 additions and 169 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/concurrency/distributed/distributed-tests.factor
View File

@ -16,7 +16,7 @@ CONSTANT: test-ip "127.0.0.1"
: test-node-client ( -- addrspec ) : test-node-client ( -- addrspec )
{ {
{ [ os unix? ] [ "distributed-concurrency-test" temp-file <local> ] } { [ os unix? ] [ "distributed-concurrency-test" temp-file <local> ] }
{ [ os windows? ] [ test-ip insecure-port <inet4> ] } { [ os windows? ] [ insecure-addr ] }
} cond ; } cond ;

4
basis/ftp/client/client.factor
View File

@ -61,7 +61,7 @@ ERROR: ftp-error got expected ;
strings>> first "|" split 2 tail* first string>number ; strings>> first "|" split 2 tail* first string>number ;
: open-passive-client ( url protocol -- stream ) : 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 ) : list ( url -- ftp-response )
utf8 open-passive-client utf8 open-passive-client
@ -84,7 +84,7 @@ ERROR: ftp-error got expected ;
ftp-set-binary 200 ftp-assert ; ftp-set-binary 200 ftp-assert ;
: ftp-connect ( url -- stream ) : ftp-connect ( url -- stream )
[ host>> ] [ port>> ] bi <inet> utf8 <client> drop ; addr>> utf8 <client> drop ;
: with-ftp-client ( url quot -- ) : with-ftp-client ( url quot -- )
[ [ ftp-connect ] keep ] dip [ [ ftp-connect ] keep ] dip

6
basis/ftp/server/server-tests.factor
View File

@ -17,11 +17,9 @@ CONSTANT: test-file-contents "Files are so boring anymore."
'[ '[
current-temporary-directory get current-temporary-directory get
0 <ftp-server> [ 0 <ftp-server> [
insecure-port insecure-addr
<url> >url
swap >>port
"ftp" >>protocol "ftp" >>protocol
"localhost" >>host
create-test-file >>path create-test-file >>path
@ @
] with-threaded-server ] with-threaded-server

6
basis/furnace/utilities/utilities.factor
View File

@ -96,7 +96,7 @@ CONSTANT: nested-forms-key "__n"
: referrer ( -- referrer/f ) : referrer ( -- referrer/f )
#! Typo is intentional, it's in the HTTP spec! #! Typo is intentional, it's in the HTTP spec!
"referer" request get header>> at "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 ( -- user-agent )
"user-agent" request get header>> at "" or ; "user-agent" request get header>> at "" or ;
@ -105,9 +105,7 @@ CONSTANT: nested-forms-key "__n"
dup [ dup [
url get [ url get [
[ protocol>> ] [ protocol>> ]
[ host>> ] [ addr>> remap-addr ] bi 2array
[ port>> remap-port ]
tri 3array
] bi@ = ] bi@ =
] when ; ] when ;

6
basis/http/client/client-tests.factor
View File

@ -1,5 +1,5 @@
USING: http.client http.client.private http tools.test USING: http.client http.client.private http tools.test
namespaces urls ; namespaces urls io.sockets ;
IN: http.client.tests IN: http.client.tests
[ "localhost" f ] [ "localhost" parse-host ] unit-test [ "localhost" f ] [ "localhost" parse-host ] unit-test
@ -12,7 +12,7 @@ IN: http.client.tests
[ [
T{ request 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" } { method "GET" }
{ version "1.1" } { version "1.1" }
{ cookies V{ } } { cookies V{ } }
@ -26,7 +26,7 @@ IN: http.client.tests
[ [
T{ request 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" } { method "GET" }
{ version "1.1" } { version "1.1" }
{ cookies V{ } } { cookies V{ } }

10
basis/http/client/client.factor
View File

@ -24,13 +24,13 @@ ERROR: too-many-redirects ;
: default-port? ( url -- ? ) : default-port? ( url -- ? )
{ {
[ port>> not ] [ addr>> port>> not ]
[ [ port>> ] [ protocol>> protocol-port ] bi = ] [ [ addr>> port>> ] [ protocol>> protocol-port ] bi = ]
} 1|| ; } 1|| ;
: unparse-host ( url -- string ) : unparse-host ( url -- string )
dup default-port? [ host>> ] [ dup default-port? [ addr>> host>> ] [
[ host>> ] [ port>> number>string ] bi ":" glue [ addr>> host>> ] [ addr>> port>> number>string ] bi ":" glue
] if ; ] if ;
: set-host-header ( request header -- request header ) : set-host-header ( request header -- request header )
@ -41,7 +41,7 @@ ERROR: too-many-redirects ;
: write-request-header ( request -- request ) : write-request-header ( request -- request )
dup header>> >hashtable 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 post-data>> [ set-post-data-headers ] when*
over cookies>> [ set-cookie-header ] unless-empty over cookies>> [ set-cookie-header ] unless-empty
write-header ; write-header ;

65
basis/http/http-tests.factor
View File

@ -17,11 +17,11 @@ IN: http.tests
[ "localhost" f ] [ "localhost" parse-host ] unit-test [ "localhost" f ] [ "localhost" parse-host ] unit-test
[ "localhost" 8888 ] [ "localhost:8888" 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" } { addr T{ inet f "localhost" } } } unparse-host ] unit-test
[ "localhost" ] [ T{ url { protocol "http" } { host "localhost" } { port 80 } } unparse-host ] unit-test [ "localhost" ] [ T{ url { protocol "http" } { addr T{ inet f "localhost" 80 } } } unparse-host ] unit-test
[ "localhost" ] [ T{ url { protocol "https" } { host "localhost" } { port 443 } } 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" } { host "localhost" } { port 8080 } } 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" } { host "localhost" } { port 8443 } } 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 ; : lf>crlf ( string -- string' ) "\n" split "\r\n" join ;
@ -37,7 +37,7 @@ blah
[ [
T{ request T{ request
{ url T{ url { path "/bar" } } } { url T{ url { path "/bar" } { addr T{ inet } } } }
{ method "POST" } { method "POST" }
{ version "1.1" } { version "1.1" }
{ header H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } } } { header H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } } }
@ -76,7 +76,7 @@ Host: www.sex.com
[ [
T{ request 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" } { method "HEAD" }
{ version "1.1" } { version "1.1" }
{ header H{ { "host" "www.sex.com" } } } { header H{ { "host" "www.sex.com" } } }
@ -97,7 +97,7 @@ Host: www.sex.com:101
[ [
T{ request 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" } { method "HEAD" }
{ version "1.1" } { version "1.1" }
{ header H{ { "host" "www.sex.com:101" } } } { header H{ { "host" "www.sex.com:101" } } }
@ -232,14 +232,14 @@ test-db [
0 >>insecure 0 >>insecure
f >>secure f >>secure
start-server start-server
servers>> random addr>> port>> servers>> random addr>>
] with-scope "port" set ; ] with-scope "addr" set ;
: add-port ( url -- url' ) : add-addr ( url -- url' )
>url clone "port" get >>port ; >url clone "addr" get >>addr ;
: stop-test-httpd ( -- ) : stop-test-httpd ( -- )
"http://localhost/quit" add-port http-get nip "http://localhost/quit" add-addr http-get nip
"Goodbye" assert= ; "Goodbye" assert= ;
[ ] [ [ ] [
@ -257,14 +257,14 @@ test-db [
[ t ] [ [ t ] [
"vocab:http/test/foo.html" ascii file-contents "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 ] 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 [ too-many-redirects? ] must-fail-with
[ "Goodbye" ] [ [ "Goodbye" ] [
"http://localhost/quit" add-port http-get nip "http://localhost/quit" add-addr http-get nip
] unit-test ] unit-test
! HTTP client redirect bug ! HTTP client redirect bug
@ -278,10 +278,9 @@ test-db [
] unit-test ] unit-test
[ "Goodbye" ] [ [ "Goodbye" ] [
"http://localhost/redirect" add-port http-get nip "http://localhost/redirect" add-addr http-get nip
] unit-test ] unit-test
[ ] [ [ ] [
[ stop-test-httpd ] ignore-errors [ stop-test-httpd ] ignore-errors
] unit-test ] unit-test
@ -305,12 +304,12 @@ test-db [
: 404? ( response -- ? ) [ download-failed? ] [ response>> code>> 404 = ] bi and ; : 404? ( response -- ? ) [ download-failed? ] [ response>> code>> 404 = ] bi and ;
! This should give a 404 not an infinite redirect loop ! 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 ! 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> <dispatcher>
@ -324,9 +323,9 @@ test-db [
test-httpd test-httpd
] unit-test ] 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 USING: html.components html.forms
xml xml.traversal validators xml xml.traversal validators
@ -356,7 +355,7 @@ SYMBOL: a
string>xml body>> "input" deep-tag-named "value" attr ; string>xml body>> "input" deep-tag-named "value" attr ;
[ "3" ] [ [ "3" ] [
"http://localhost/" add-port http-get "http://localhost/" add-addr http-get
swap dup cookies>> "cookies" set session-id-key get-cookie swap dup cookies>> "cookies" set session-id-key get-cookie
value>> "session-id" set test-a value>> "session-id" set test-a
] unit-test ] unit-test
@ -364,10 +363,10 @@ SYMBOL: a
[ "4" ] [ [ "4" ] [
[ [
"4" "a" set "4" "a" set
"http://localhost" add-port "__u" set "http://localhost" add-addr "__u" set
"session-id" get session-id-key set "session-id" get session-id-key set
] H{ } make-assoc ] 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 ] unit-test
[ 4 ] [ a get-global ] unit-test [ 4 ] [ a get-global ] unit-test
@ -376,15 +375,15 @@ SYMBOL: a
[ "xyz" ] [ [ "xyz" ] [
[ [
"xyz" "a" set "xyz" "a" set
"http://localhost" add-port "__u" set "http://localhost" add-addr "__u" set
"session-id" get session-id-key set "session-id" get session-id-key set
] H{ } make-assoc ] 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 ] unit-test
[ 4 ] [ a get-global ] 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 ! Test cloning
[ f ] [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test [ f ] [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test
@ -402,7 +401,7 @@ SYMBOL: a
] unit-test ] unit-test
[ t ] [ [ t ] [
"http://localhost/" add-port http-get nip "http://localhost/" add-addr http-get nip
"vocab:http/test/foo.html" ascii file-contents = "vocab:http/test/foo.html" ascii file-contents =
] unit-test ] unit-test
@ -424,12 +423,12 @@ SYMBOL: a
test-httpd test-httpd
] unit-test ] 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) ! Check that download throws errors (reported by Chris Double)
[ [
"resource:temp" [ "resource:temp" [
"http://localhost/tweet_my_twat" add-port download "http://localhost/tweet_my_twat" add-addr download
] with-directory ] with-directory
] must-fail ] must-fail
@ -443,6 +442,6 @@ SYMBOL: a
test-httpd test-httpd
] unit-test ] 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 [ ] [ stop-test-httpd ] unit-test

6
basis/http/server/redirection/redirection-tests.factor
View File

@ -1,12 +1,12 @@
USING: http http.server.redirection urls accessors USING: accessors http http.server.redirection io.sockets kernel
namespaces tools.test present kernel ; namespaces present tools.test urls ;
IN: http.server.redirection.tests IN: http.server.redirection.tests
[ [
<request> <request>
<url> <url>
"http" >>protocol "http" >>protocol
"www.apple.com" >>host T{ inet f "www.apple.com" } >>addr
"/xxx/bar" >>path "/xxx/bar" >>path
{ { "a" "b" } } >>query { { "a" "b" } } >>query
dup url set dup url set

2
basis/http/server/remapping/remapping-docs.factor
View File

@ -18,7 +18,7 @@ $nl
{ $subsections port-remapping } { $subsections port-remapping }
"For example, with the above setup, we would set it as follows:" "For example, with the above setup, we would set it as follows:"
{ $code { $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" ABOUT: "http.server.remapping"

6
basis/http/server/remapping/remapping.factor
View File

@ -5,8 +5,8 @@ IN: http.server.remapping
SYMBOL: port-remapping SYMBOL: port-remapping
: remap-port ( n -- n' ) : remap-addr ( addr -- addr' )
[ port-remapping get at ] keep or ; [ port-remapping get at ] keep or ;
: secure-http-port ( -- n ) : secure-http-port ( -- addr )
secure-port remap-port ; secure-addr remap-addr ;

12
basis/http/server/server.factor
View File

@ -82,8 +82,7 @@ upload-limit [ 200,000,000 ] initialize
] when ; ] when ;
: extract-host ( request -- request ) : extract-host ( request -- request )
[ ] [ url>> ] [ "host" header parse-host ] tri [ ] [ url>> ] [ "host" header parse-host <inet> >>addr ] tri
[ >>host ] [ >>port ] bi*
drop ; drop ;
: extract-cookies ( request -- request ) : extract-cookies ( request -- request )
@ -116,7 +115,7 @@ GENERIC: write-full-response ( request response -- )
: ensure-domain ( cookie -- cookie ) : ensure-domain ( cookie -- cookie )
[ [
url get host>> dup "localhost" = url get addr>> host>> dup "localhost" =
[ drop ] [ or ] if [ drop ] [ or ] if
] change-domain ; ] change-domain ;
@ -251,13 +250,12 @@ SYMBOL: params
[ [
local-address get local-address get
[ secure? "https" "http" ? >>protocol ] [ secure? "https" "http" ? >>protocol ]
[ port>> remap-port '[ _ or ] change-port ] [ remap-addr '[ _ or ] change-addr ] bi
bi
] change-url drop ; ] change-url drop ;
: valid-request? ( request -- ? ) : valid-request? ( request -- ? )
url>> port>> remap-port url>> addr>> remap-addr
local-address get port>> remap-port = ; local-address get remap-addr = ;
: do-request ( request -- response ) : do-request ( request -- response )
'[ '[

12
basis/io/servers/servers-docs.factor
View File

@ -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:" "From within the dynamic scope of a client handler, several words can be used to interact with the threaded server:"
{ $subsections { $subsections
stop-this-server stop-this-server
secure-port secure-addr
insecure-port insecure-addr
} }
"Additionally, the " { $link local-address } " and " "Additionally, the " { $link local-address } " and "
{ $subsections remote-address } " variables are set, as in " { $link with-client } "." ; { $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." } ; { $description "Runs a server and calls a quotation, stopping the server once the quotation returns." } ;
HELP: secure-port HELP: secure-addr
{ $values { "n/f" { $maybe integer } } } { $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." } { $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." } ; { $notes "Can only be used from the dynamic scope of a " { $link handle-client* } " call." } ;
HELP: insecure-port HELP: insecure-addr
{ $values { "n/f" { $maybe integer } } } { $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." } { $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." } ; { $notes "Can only be used from the dynamic scope of a " { $link handle-client* } " call." } ;

2
basis/io/servers/servers-tests.factor
View File

@ -34,7 +34,7 @@ IN: io.servers
0 >>insecure 0 >>insecure
[ "Hello world." write stop-this-server ] >>handler [ "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 ] with-threaded-server
] unit-test ] unit-test

22
basis/io/servers/servers.factor
View File

@ -219,23 +219,13 @@ PRIVATE>
[ ] cleanup [ ] cleanup
] call ; inline ] call ; inline
<PRIVATE : secure-addr ( -- inet/f )
threaded-server get servers>>
[ addr>> ] map [ secure? ] filter random ;
: first-port ( quot -- n/f ) : insecure-addr ( -- inet/f )
[ threaded-server get servers>> ] dip threaded-server get servers>>
filter [ f ] [ first addr>> port>> ] if-empty ; inline [ addr>> ] map [ secure? not ] filter random ;
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>> ;
: server. ( threaded-server -- ) : server. ( threaded-server -- )
[ [ "=== " write name>> ] [ ] bi write-object nl ] [ [ "=== " write name>> ] [ ] bi write-object nl ]

10
basis/io/sockets/sockets-docs.factor
View File

@ -118,10 +118,10 @@ HELP: inet
HELP: <inet> HELP: <inet>
{ $values { "host" "a host name" } { "port" "a port number" } { "inet" 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 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 } "." } { $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 { $examples
{ $code "\"127.0.0.1\" 8080 <inet4>" } { $code "\"127.0.0.1\" 8080 <inet4>" }
@ -129,10 +129,10 @@ HELP: inet4
HELP: <inet4> HELP: <inet4>
{ $values { "host" "an IPv4 address" } { "port" "a port number" } { "inet4" 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 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 } "." } { $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 { $examples
{ $code "\"::1\" 8080 <inet6>" } { $code "\"::1\" 8080 <inet6>" }
@ -140,7 +140,7 @@ HELP: inet6
HELP: <inet6> HELP: <inet6>
{ $values { "host" "an IPv6 address" } { "port" "a port number" } { "inet6" 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> HELP: <client>
{ $values { "remote" "an address specifier" } { "encoding" "an encding descriptor" } { "stream" "a bidirectional stream" } { "local" "an address specifier" } } { $values { "remote" "an address specifier" } { "encoding" "an encding descriptor" } { "stream" "a bidirectional stream" } { "local" "an address specifier" } }

14
basis/io/sockets/sockets-tests.factor
View File

@ -1,8 +1,17 @@
IN: io.sockets.tests
USING: io.sockets io.sockets.private sequences math tools.test USING: io.sockets io.sockets.private sequences math tools.test
namespaces accessors kernel destructors calendar io.timeouts namespaces accessors kernel destructors calendar io.timeouts
io.encodings.utf8 io concurrency.promises threads io.encodings.utf8 io concurrency.promises threads
io.streams.string ; 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 } ] [ B{ 1 2 3 4 } ]
[ "1.2.3.4" T{ inet4 } inet-pton ] unit-test [ "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 } ] [ B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } ]
[ "::" T{ inet6 } inet-pton ] unit-test [ "::" 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" ] [ "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 [ 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 ! Binding to all interfaces should work
[ ] [ f 0 <inet4> <datagram> dispose ] unit-test [ ] [ f 0 <inet4> <datagram> dispose ] unit-test
[ ] [ f 0 <inet6> <datagram> dispose ] unit-test

46
basis/io/sockets/sockets.factor
View File

@ -37,8 +37,6 @@ GENERIC: inet-ntop ( data addrspec -- str )
GENERIC: inet-pton ( str addrspec -- data ) GENERIC: inet-pton ( str addrspec -- data )
GENERIC# with-port 1 ( addrspec port -- addrspec )
: make-sockaddr/size ( addrspec -- sockaddr size ) : make-sockaddr/size ( addrspec -- sockaddr size )
[ make-sockaddr ] [ sockaddr-size ] bi ; [ make-sockaddr ] [ sockaddr-size ] bi ;
@ -55,6 +53,8 @@ HOOK: addrspec-of-family os ( af -- addrspec )
PRIVATE> PRIVATE>
GENERIC# with-port 1 ( addrspec port -- addrspec )
TUPLE: local { path read-only } ; TUPLE: local { path read-only } ;
: <local> ( path -- addrspec ) : <local> ( path -- addrspec )
@ -113,7 +113,18 @@ M: ipv4 parse-sockaddr ( sockaddr-in addrspec -- newaddrspec )
TUPLE: inet4 < ipv4 { port integer read-only } ; 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> ; M: ipv4 with-port [ host>> ] dip <inet4> ;
@ -165,11 +176,13 @@ ERROR: more-than-8-components ;
PRIVATE> PRIVATE>
ERROR: empty-ipv6 ;
M: ipv6 inet-pton ( str addrspec -- data ) M: ipv6 inet-pton ( str addrspec -- data )
drop drop [
[ "::" split1 [ parse-ipv6 ] bi@ pad-ipv6 ipv6-bytes ] [ empty-ipv6 ]
[ invalid-ipv6 ] [ "::" split1 [ parse-ipv6 ] bi@ pad-ipv6 ipv6-bytes ] if-empty
recover ; ] [ invalid-ipv6 ] recover ;
M: ipv6 address-size drop 16 ; M: ipv6 address-size drop 16 ;
@ -192,7 +205,15 @@ M: ipv6 parse-sockaddr
TUPLE: inet6 < ipv6 { port integer read-only } ; 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: ipv6 with-port [ host>> ] dip <inet6> ;
@ -365,7 +386,14 @@ TUPLE: inet < hostname port ;
M: inet present M: inet present
[ host>> ] [ port>> number>string ] bi ":" glue ; [ 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 M: string resolve-host
f prepare-addrinfo f <void*> f prepare-addrinfo f <void*>

8
basis/urls/urls-docs.factor
View File

@ -24,7 +24,7 @@ HELP: >url
"We can examine the URL object:" "We can examine the URL object:"
{ $example { $example
"USING: accessors io urls ;" "USING: accessors io urls ;"
"\"http://www.apple.com\" >url host>> print" "\"http://www.apple.com\" >url addr>> host>> print"
"www.apple.com" "www.apple.com"
} }
"A relative URL does not have a protocol, host or port:" "A relative URL does not have a protocol, host or port:"
@ -41,7 +41,7 @@ HELP: URL"
{ $examples { $examples
{ $example { $example
"USING: accessors prettyprint urls ;" "USING: accessors prettyprint urls ;"
"URL\" http://factorcode.org:80\" port>> ." "URL\" http://factorcode.org:80\" addr>> port>> ."
"80" "80"
} }
} ; } ;
@ -70,13 +70,13 @@ HELP: ensure-port
{ $examples { $examples
{ $example { $example
"USING: accessors prettyprint urls ;" "USING: accessors prettyprint urls ;"
"URL\" https://concatenative.org\" ensure-port port>> ." "URL\" https://concatenative.org\" ensure-port addr>> port>> ."
"443" "443"
} }
} ; } ;
HELP: parse-host 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 } "." } { $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." } { $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 { $examples

46
basis/urls/urls-tests.factor
View File

@ -1,14 +1,13 @@
USING: accessors arrays assocs io.sockets kernel present
prettyprint tools.test urls urls.private ;
IN: urls.tests IN: urls.tests
USING: urls urls.private tools.test prettyprint
arrays kernel assocs present accessors ;
CONSTANT: urls CONSTANT: urls
{ {
{ {
T{ url T{ url
{ protocol "http" } { protocol "http" }
{ host "www.apple.com" } { addr T{ inet f "www.apple.com" 1234 } }
{ port 1234 }
{ path "/a/path" } { path "/a/path" }
{ query H{ { "a" "b" } } } { query H{ { "a" "b" } } }
{ anchor "foo" } { anchor "foo" }
@ -18,7 +17,7 @@ CONSTANT: urls
{ {
T{ url T{ url
{ protocol "http" } { protocol "http" }
{ host "www.apple.com" } { addr T{ inet f "www.apple.com" } }
{ path "/a/path" } { path "/a/path" }
{ query H{ { "a" "b" } } } { query H{ { "a" "b" } } }
{ anchor "foo" } { anchor "foo" }
@ -28,8 +27,7 @@ CONSTANT: urls
{ {
T{ url T{ url
{ protocol "http" } { protocol "http" }
{ host "www.apple.com" } { addr T{ inet f "www.apple.com" 1234 } }
{ port 1234 }
{ path "/another/fine/path" } { path "/another/fine/path" }
{ anchor "foo" } { anchor "foo" }
} }
@ -64,7 +62,7 @@ CONSTANT: urls
{ {
T{ url T{ url
{ protocol "ftp" } { protocol "ftp" }
{ host "ftp.kernel.org" } { addr T{ inet f "ftp.kernel.org" } }
{ username "slava" } { username "slava" }
{ path "/" } { path "/" }
} }
@ -73,7 +71,7 @@ CONSTANT: urls
{ {
T{ url T{ url
{ protocol "ftp" } { protocol "ftp" }
{ host "ftp.kernel.org" } { addr T{ inet f "ftp.kernel.org" } }
{ username "slava" } { username "slava" }
{ password "secret" } { password "secret" }
{ path "/" } { path "/" }
@ -83,7 +81,7 @@ CONSTANT: urls
{ {
T{ url T{ url
{ protocol "http" } { protocol "http" }
{ host "foo.com" } { addr T{ inet f "foo.com" } }
{ path "/" } { path "/" }
{ query H{ { "a" f } } } { query H{ { "a" f } } }
} }
@ -114,15 +112,13 @@ urls [
[ [
T{ url T{ url
{ protocol "http" } { protocol "http" }
{ host "www.apple.com" } { addr T{ inet f "www.apple.com" 1234 } }
{ port 1234 }
{ path "/a/path" } { path "/a/path" }
} }
] [ ] [
T{ url T{ url
{ protocol "http" } { protocol "http" }
{ host "www.apple.com" } { addr T{ inet f "www.apple.com" 1234 } }
{ port 1234 }
{ path "/foo" } { path "/foo" }
} }
@ -136,8 +132,7 @@ urls [
[ [
T{ url T{ url
{ protocol "http" } { protocol "http" }
{ host "www.apple.com" } { addr T{ inet f "www.apple.com" 1234 } }
{ port 1234 }
{ path "/a/path/relative/path" } { path "/a/path/relative/path" }
{ query H{ { "a" "b" } } } { query H{ { "a" "b" } } }
{ anchor "foo" } { anchor "foo" }
@ -145,8 +140,7 @@ urls [
] [ ] [
T{ url T{ url
{ protocol "http" } { protocol "http" }
{ host "www.apple.com" } { addr T{ inet f "www.apple.com" 1234 } }
{ port 1234 }
{ path "/a/path/" } { path "/a/path/" }
} }
@ -162,8 +156,7 @@ urls [
[ [
T{ url T{ url
{ protocol "http" } { protocol "http" }
{ host "www.apple.com" } { addr T{ inet f "www.apple.com" 1234 } }
{ port 1234 }
{ path "/a/path/relative/path" } { path "/a/path/relative/path" }
{ query H{ { "a" "b" } } } { query H{ { "a" "b" } } }
{ anchor "foo" } { anchor "foo" }
@ -171,8 +164,7 @@ urls [
] [ ] [
T{ url T{ url
{ protocol "http" } { protocol "http" }
{ host "www.apple.com" } { addr T{ inet f "www.apple.com" 1234 } }
{ port 1234 }
{ path "/a/path/" } { path "/a/path/" }
} }
@ -188,13 +180,13 @@ urls [
[ [
T{ url T{ url
{ protocol "http" } { protocol "http" }
{ host "www.apple.com" } { addr T{ inet f "www.apple.com" } }
{ path "/xxx/baz" } { path "/xxx/baz" }
} }
] [ ] [
T{ url T{ url
{ protocol "http" } { protocol "http" }
{ host "www.apple.com" } { addr T{ inet f "www.apple.com" } }
{ path "/xxx/bar" } { path "/xxx/bar" }
} }
@ -218,7 +210,7 @@ urls [
[ [
T{ url T{ url
{ protocol "http" } { protocol "http" }
{ host "localhost" } { addr T{ inet f "localhost" } }
{ query H{ { "foo" "bar" } } } { query H{ { "foo" "bar" } } }
{ path "/" } { path "/" }
} }
@ -228,7 +220,7 @@ urls [
[ [
T{ url T{ url
{ protocol "http" } { protocol "http" }
{ host "localhost" } { addr T{ inet f "localhost" } }
{ query H{ { "foo" "bar" } } } { query H{ { "foo" "bar" } } }
{ path "/" } { path "/" }
} }
@ -237,4 +229,4 @@ urls [
[ "/" ] [ "http://www.jedit.org" >url path>> ] unit-test [ "/" ] [ "http://www.jedit.org" >url path>> ] unit-test
[ "USING: urls ;\nURL\" foo\"" ] [ URL" foo" unparse-use ] unit-test [ "USING: urls ;\nURL\" foo\"" ] [ URL" foo" unparse-use ] unit-test

76
basis/urls/urls.factor
View File

@ -1,13 +1,13 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel ascii combinators combinators.short-circuit USING: accessors arrays ascii assocs classes combinators
sequences splitting fry namespaces make assocs arrays strings combinators.short-circuit fry hashtables io.encodings.string
io.sockets io.encodings.string io.encodings.utf8 math io.encodings.utf8 io.sockets kernel lexer make math math.parser
math.parser accessors parser strings.parser lexer namespaces parser peg.ebnf present sequences splitting strings
hashtables present peg.ebnf urls.encoding ; strings.parser urls.encoding ;
IN: urls 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 ; : <url> ( -- url ) url new ;
@ -24,14 +24,12 @@ TUPLE: url protocol username password host port path query anchor ;
nip delete-query-param nip delete-query-param
] if ; ] if ;
: parse-host ( string -- host port ) ERROR: malformed-port ;
: parse-host ( string -- host/f port/f )
[ [
":" split1 [ url-decode ] [ ":" split1-last [ url-decode ]
dup [ [ dup [ string>number [ malformed-port ] unless* ] when ] bi*
string>number
dup [ "Invalid port" throw ] unless
] when
] bi*
] [ f f ] if* ; ] [ f f ] if* ;
GENERIC: >url ( obj -- url ) GENERIC: >url ( obj -- url )
@ -68,23 +66,33 @@ url = ((protocol "://") => [[ first ]] auth hostname)?
PRIVATE> PRIVATE>
M: string >url M: string >url
[ <url> ] dip
parse-url { parse-url {
[ [
first [ first [
[ first ] ! protocol [ first >>protocol ]
[ [
second second
[ first [ first2 ] [ f f ] if* ] ! username, password [ first [ first2 [ >>username ] [ >>password ] bi* ] when* ]
[ second parse-host ] ! host, port [ second parse-host <inet> >>addr ] bi
bi
] bi ] bi
] [ f f f f f ] if* ] when*
] ]
[ second ] ! pathname [ second >>path ]
[ third ] ! query [ third >>query ]
[ fourth ] ! anchor [ fourth >>anchor ]
} cleave url boa } cleave
dup host>> [ [ "/" or ] change-path ] when ; 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 ) : protocol-port ( protocol -- port )
{ {
@ -102,7 +110,9 @@ M: string >url
] [ 2drop ] if ; ] [ 2drop ] if ;
: url-port ( url -- port/f ) : url-port ( url -- port/f )
[ port>> ] [ port>> ] [ protocol>> protocol-port ] tri = [ addr>> port>> ]
[ addr>> port>> ]
[ protocol>> protocol-port ] tri =
[ drop f ] when ; [ drop f ] when ;
: unparse-host-part ( url protocol -- ) : unparse-host-part ( url protocol -- )
@ -110,7 +120,7 @@ M: string >url
"://" % "://" %
{ {
[ unparse-username-password ] [ unparse-username-password ]
[ host>> url-encode % ] [ addr>> host>> url-encode % ]
[ url-port [ ":" % # ] when* ] [ url-port [ ":" % # ] when* ]
[ path>> "/" head? [ "/" % ] unless ] [ path>> "/" head? [ "/" % ] unless ]
} cleave ; } cleave ;
@ -143,8 +153,7 @@ PRIVATE>
[ [ protocol>> ] either? >>protocol ] [ [ protocol>> ] either? >>protocol ]
[ [ username>> ] either? >>username ] [ [ username>> ] either? >>username ]
[ [ password>> ] either? >>password ] [ [ password>> ] either? >>password ]
[ [ host>> ] either? >>host ] [ [ addr>> ] either? >>addr ]
[ [ port>> ] either? >>port ]
[ [ path>> ] bi@ swap url-append-path >>path ] [ [ path>> ] bi@ swap url-append-path >>path ]
[ [ query>> ] either? >>query ] [ [ query>> ] either? >>query ]
[ [ anchor>> ] either? >>anchor ] [ [ anchor>> ] either? >>anchor ]
@ -153,8 +162,7 @@ PRIVATE>
: relative-url ( url -- url' ) : relative-url ( url -- url' )
clone clone
f >>protocol f >>protocol
f >>host f >>addr ;
f >>port ;
: relative-url? ( url -- ? ) protocol>> not ; : relative-url? ( url -- ? ) protocol>> not ;
@ -170,15 +178,15 @@ PRIVATE>
: url-addr ( url -- addr ) : url-addr ( url -- addr )
[ [
[ host>> ] [ addr>> ]
[ port>> ] [ [ addr>> port>> ] [ protocol>> protocol-port ] bi or ] bi with-port
[ protocol>> protocol-port ]
tri or <inet>
] [ protocol>> ] bi ] [ protocol>> ] bi
secure-protocol? [ >secure-addr ] when ; secure-protocol? [ >secure-addr ] when ;
: ensure-port ( url -- url' ) : 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 ! Literal syntax
SYNTAX: URL" lexer get skip-blank parse-string >url suffix! ; SYNTAX: URL" lexer get skip-blank parse-string >url suffix! ;