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

Various cleanups for Doug's recent socket addressing change 

- urls: now have a host/port slots again, add a new set-url-addr word
- http.server: fix host header parsing for IPv6 addresses
db4
Slava Pestov 2010-10-06 23:00:38 -07:00
parent 4376173e83
commit 89ae9d9638
17 changed files with 157 additions and 147 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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 )
[ addr>> ftp-epsv parse-epsv with-port ] dip <client> drop ; [ url-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 )
addr>> utf8 <client> drop ; url-addr utf8 <client> drop ;
: with-ftp-client ( url quot -- ) : with-ftp-client ( url quot -- )
[ [ ftp-connect ] keep ] dip [ [ ftp-connect ] keep ] dip

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

@ -17,8 +17,7 @@ CONSTANT: test-file-contents "Files are so boring anymore."
'[ '[
current-temporary-directory get current-temporary-directory get
0 <ftp-server> [ 0 <ftp-server> [
insecure-addr "ftp://localhost" >url insecure-addr set-url-addr
>url
"ftp" >>protocol "ftp" >>protocol
create-test-file >>path create-test-file >>path
@ @

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-addr ] change-addr ] when ; dup [ >url ensure-port [ remap-port ] change-port ] when ;
: user-agent ( -- user-agent ) : user-agent ( -- user-agent )
"user-agent" request get header>> at "" or ; "user-agent" request get header>> at "" or ;
@ -105,7 +105,9 @@ CONSTANT: nested-forms-key "__n"
dup [ dup [
url get [ url get [
[ protocol>> ] [ protocol>> ]
[ addr>> remap-addr ] bi 2array [ host>> ]
[ 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 io.sockets ; namespaces urls ;
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" } { addr T{ inet f "www.apple.com" 80 } } { path "/index.html" } } } { url T{ url { protocol "http" } { host "www.apple.com" } { port 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" } { addr T{ inet f "www.amazon.com" 443 } } { path "/index.html" } } } { url T{ url { protocol "https" } { host "www.amazon.com" } { port 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 -- ? )
{ {
[ addr>> port>> not ] [ port>> not ]
[ [ addr>> port>> ] [ protocol>> protocol-port ] bi = ] [ [ port>> ] [ protocol>> protocol-port ] bi = ]
} 1|| ; } 1|| ;
: unparse-host ( url -- string ) : unparse-host ( url -- string )
dup default-port? [ addr>> host>> ] [ dup default-port? [ host>> ] [
[ addr>> host>> ] [ addr>> port>> number>string ] bi ":" glue [ host>> ] [ 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>> addr>> host>> [ set-host-header ] when over url>> 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 ;

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

@ -3,7 +3,7 @@ multiline io.streams.string io.encodings.utf8 io.encodings.8-bit
io.encodings.binary io.encodings.string io.encodings.ascii kernel io.encodings.binary io.encodings.string io.encodings.ascii kernel
arrays splitting sequences assocs io.sockets db db.sqlite arrays splitting sequences assocs io.sockets db db.sqlite
continuations urls hashtables accessors namespaces xml.data continuations urls hashtables accessors namespaces xml.data
io.encodings.8-bit.latin1 random ; io.encodings.8-bit.latin1 random combinators.short-circuit ;
IN: http.tests IN: http.tests
[ "text/plain" "UTF-8" ] [ "text/plain" parse-content-type ] unit-test [ "text/plain" "UTF-8" ] [ "text/plain" parse-content-type ] unit-test
@ -16,12 +16,14 @@ 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
[ "::1" 8888 ] [ "::1:8888" parse-host ] unit-test
[ "127.0.0.1" 8888 ] [ "127.0.0.1:8888" parse-host ] unit-test
[ "localhost" ] [ T{ url { protocol "http" } { addr T{ inet f "localhost" } } } unparse-host ] unit-test [ "localhost" ] [ T{ url { protocol "http" } { host "localhost" } } unparse-host ] unit-test
[ "localhost" ] [ T{ url { protocol "http" } { addr T{ inet f "localhost" 80 } } } unparse-host ] unit-test [ "localhost" ] [ T{ url { protocol "http" } { host "localhost" } { port 80 } } unparse-host ] unit-test
[ "localhost" ] [ T{ url { protocol "https" } { addr T{ inet f "localhost" 443 } } } unparse-host ] unit-test [ "localhost" ] [ T{ url { protocol "https" } { host "localhost" } { port 443 } } unparse-host ] unit-test
[ "localhost:8080" ] [ T{ url { protocol "http" } { addr T{ inet f "localhost" 8080 } } } unparse-host ] unit-test [ "localhost:8080" ] [ T{ url { protocol "http" } { host "localhost" } { port 8080 } } unparse-host ] unit-test
[ "localhost:8443" ] [ T{ url { protocol "https" } { addr T{ inet f "localhost" 8443 } } } unparse-host ] unit-test [ "localhost:8443" ] [ T{ url { protocol "https" } { host "localhost" } { port 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 +39,7 @@ blah
[ [
T{ request T{ request
{ url T{ url { path "/bar" } { addr T{ inet } } } } { url T{ url { path "/bar" } } }
{ 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 +78,7 @@ Host: www.sex.com
[ [
T{ request T{ request
{ url T{ url { addr T{ inet f "www.sex.com" } } { path "/bar" } } } { url T{ url { host "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 +99,7 @@ Host: www.sex.com:101
[ [
T{ request T{ request
{ url T{ url { addr T{ inet f "www.sex.com" 101 } } { path "/bar" } } } { url T{ url { host "www.sex.com" } { port 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" } } }
@ -219,12 +221,6 @@ http.server.dispatchers db.tuples ;
: test-db ( -- db ) test-db-file <sqlite-db> ; : test-db ( -- db ) test-db-file <sqlite-db> ;
[ test-db-file delete-file ] ignore-errors
test-db [
init-furnace-tables
] with-db
: test-httpd ( responder -- ) : test-httpd ( responder -- )
[ [
main-responder set main-responder set
@ -232,16 +228,25 @@ test-db [
0 >>insecure 0 >>insecure
f >>secure f >>secure
start-server start-server
servers>> random addr>> threaded-server set
server-addrs random
] with-scope "addr" set ; ] with-scope "addr" set ;
: add-addr ( url -- url' ) : add-addr ( url -- url' )
>url clone "addr" get >>addr ; >url clone "addr" get set-url-addr ;
: stop-test-httpd ( -- ) : stop-test-httpd ( -- )
"http://localhost/quit" add-addr http-get nip "http://localhost/quit" add-addr http-get nip
"Goodbye" assert= ; "Goodbye" assert= ;
[ ] [
[ test-db-file delete-file ] ignore-errors
test-db [
init-furnace-tables
] with-db
] unit-test
[ ] [ [ ] [
<dispatcher> <dispatcher>
add-quit-action add-quit-action
@ -281,6 +286,7 @@ test-db [
"http://localhost/redirect" add-addr 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
@ -301,7 +307,12 @@ test-db [
test-httpd test-httpd
] unit-test ] unit-test
: 404? ( response -- ? ) [ download-failed? ] [ response>> code>> 404 = ] bi and ; : 404? ( response -- ? )
{
[ download-failed? ]
[ response>> response? ]
[ response>> code>> 404 = ]
} 1&& ;
! 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-addr http-get nip ] [ 404? ] must-fail-with [ "http://localhost/d/blah" add-addr http-get nip ] [ 404? ] must-fail-with

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

@ -1,12 +1,12 @@
USING: accessors http http.server.redirection io.sockets kernel USING: http http.server.redirection urls accessors
namespaces present tools.test urls ; namespaces tools.test present kernel ;
IN: http.server.redirection.tests IN: http.server.redirection.tests
[ [
<request> <request>
<url> <url>
"http" >>protocol "http" >>protocol
T{ inet f "www.apple.com" } >>addr "www.apple.com" >>host
"/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
"{ { T{ inet4 f f 8080 } T{ inet4 f f 80 } } { T{ inet4 f f 8443 } T{ inet4 f f 443 } } } port-remapping set-global" "{ { 8080 80 } { 8443 443 } } port-remapping set-global"
} ; } ;
ABOUT: "http.server.remapping" ABOUT: "http.server.remapping"

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

@ -1,12 +1,12 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs kernel io.servers ; USING: accessors namespaces assocs kernel io.servers ;
IN: http.server.remapping IN: http.server.remapping
SYMBOL: port-remapping SYMBOL: port-remapping
: remap-addr ( addr -- addr' ) : remap-port ( n -- n' )
[ port-remapping get at ] keep or ; [ port-remapping get at ] keep or ;
: secure-http-port ( -- addr ) : secure-http-port ( -- n )
secure-addr remap-addr ; secure-addr port>> remap-port ;

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

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

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

@ -126,11 +126,11 @@ 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-addr HELP: secure-addr
{ $values { "inet/f" { $maybe inet } } } { $values { "addrspec" "an addrspec" } }
{ $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-addr HELP: insecure-addr
{ $values { "inet/f" { $maybe inet } } } { $values { "addrspec" "an addrspec" } }
{ $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." } ;

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

@ -162,7 +162,8 @@ ERROR: no-ports-configured threaded-server ;
: set-servers ( threaded-server -- threaded-server ) : set-servers ( threaded-server -- threaded-server )
dup [ dup [
dup dup listen-on [ no-ports-configured ] [ (make-servers) ] if-empty dup dup listen-on
[ no-ports-configured ] [ (make-servers) ] if-empty
>>servers >>servers
] with-existing-secure-context ; ] with-existing-secure-context ;
@ -219,13 +220,26 @@ PRIVATE>
[ ] cleanup [ ] cleanup
] call ; inline ] call ; inline
: secure-addr ( -- inet/f ) <PRIVATE
threaded-server get servers>>
[ addr>> ] map [ secure? ] filter random ;
: insecure-addr ( -- inet/f ) GENERIC: connect-addr ( addrspec -- addrspec )
threaded-server get servers>>
[ addr>> ] map [ secure? not ] filter random ; M: inet4 connect-addr [ "127.0.0.1" ] dip port>> <inet4> ;
M: inet6 connect-addr [ "::1" ] dip port>> <inet6> ;
M: secure connect-addr addrspec>> connect-addr <secure> ;
PRIVATE>
: server-addrs ( -- addrspecs )
threaded-server get servers>> [ addr>> connect-addr ] map ;
: secure-addr ( -- addrspec )
server-addrs [ secure? ] filter random ;
: insecure-addr ( -- addrspec )
server-addrs [ secure? not ] filter random ;
: server. ( threaded-server -- ) : server. ( threaded-server -- )
[ [ "=== " write name>> ] [ ] bi write-object nl ] [ [ "=== " write name>> ] [ ] bi write-object nl ]

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

@ -10,8 +10,12 @@ IN: io.sockets.tests
[ T{ inet f "google.com" f } ] [ "google.com" f <inet> ] 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{ 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{ inet f "google.com" 80 } ] [ "google.com" 0 <inet> 80 with-port ] 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 [ T{ inet4 f "8.8.8.8" 0 } ] [ "8.8.8.8" 0 <inet4> ] unit-test
[ T{ inet4 f "8.8.8.8" 53 } ] [ "8.8.8.8" 0 <inet4> 53 with-port ] unit-test
[ T{ inet6 f "5:5:5:5:6:6:6:6" 12 } ] [ "5:5:5:5:6:6:6:6" 0 <inet6> 12 with-port ] unit-test
[ T{ inet f "google.com" 80 } ] [ "google.com" 80 with-port ] 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

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

@ -16,6 +16,8 @@ IN: io.sockets
{ [ os unix? ] [ "unix.ffi" ] } { [ os unix? ] [ "unix.ffi" ] }
} cond use-vocab >> } cond use-vocab >>
GENERIC# with-port 1 ( addrspec port -- addrspec )
! Addressing ! Addressing
<PRIVATE <PRIVATE
@ -53,8 +55,6 @@ 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,18 +113,7 @@ M: ipv4 parse-sockaddr ( sockaddr-in addrspec -- newaddrspec )
TUPLE: inet4 < ipv4 { port integer read-only } ; TUPLE: inet4 < ipv4 { port integer read-only } ;
: inet-string? ( string exemplar -- ? ) C: <inet4> inet4
'[ _ _ 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> ;
@ -176,13 +165,11 @@ 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
[ empty-ipv6 ] [ "::" split1 [ parse-ipv6 ] bi@ pad-ipv6 ipv6-bytes ]
[ "::" split1 [ parse-ipv6 ] bi@ pad-ipv6 ipv6-bytes ] if-empty [ invalid-ipv6 ]
] [ invalid-ipv6 ] recover ; recover ;
M: ipv6 address-size drop 16 ; M: ipv6 address-size drop 16 ;
@ -205,15 +192,7 @@ M: ipv6 parse-sockaddr
TUPLE: inet6 < ipv6 { port integer read-only } ; TUPLE: inet6 < ipv6 { port integer read-only } ;
: inet6-string? ( string -- ? ) T{ inet6 } inet-string? ; C: <inet6> inet6
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> ;
@ -386,23 +365,21 @@ TUPLE: inet < hostname port ;
M: inet present M: inet present
[ host>> ] [ port>> number>string ] bi ":" glue ; [ host>> ] [ port>> number>string ] bi ":" glue ;
: <inet> ( host port -- inet ) C: <inet> 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*>
[ getaddrinfo addrinfo-error ] keep *void* addrinfo memory>struct [ getaddrinfo addrinfo-error ] keep *void* addrinfo memory>struct
[ parse-addrinfo-list ] keep freeaddrinfo ; [ parse-addrinfo-list ] keep freeaddrinfo ;
M: string with-port <inet> ;
M: hostname resolve-host M: hostname resolve-host
host>> resolve-host ; host>> resolve-host ;
M: hostname with-port
[ host>> ] dip <inet> ;
M: inet resolve-host M: inet resolve-host
[ call-next-method ] [ port>> ] bi '[ _ with-port ] map ; [ call-next-method ] [ port>> ] bi '[ _ with-port ] map ;

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 addr>> host>> print" "\"http://www.apple.com\" >url 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\" addr>> port>> ." "URL\" http://factorcode.org:80\" 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 addr>> port>> ." "URL\" https://concatenative.org\" ensure-port port>> ."
"443" "443"
} }
} ; } ;
HELP: parse-host HELP: parse-host
{ $values { "string" string } { "host/f" string } { "port/f" { $maybe integer } } } { $values { "string" string } { "host/f" { $maybe 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

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

@ -1,13 +1,14 @@
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" }
{ addr T{ inet f "www.apple.com" 1234 } } { host "www.apple.com" }
{ port 1234 }
{ path "/a/path" } { path "/a/path" }
{ query H{ { "a" "b" } } } { query H{ { "a" "b" } } }
{ anchor "foo" } { anchor "foo" }
@ -17,7 +18,7 @@ CONSTANT: urls
{ {
T{ url T{ url
{ protocol "http" } { protocol "http" }
{ addr T{ inet f "www.apple.com" } } { host "www.apple.com" }
{ path "/a/path" } { path "/a/path" }
{ query H{ { "a" "b" } } } { query H{ { "a" "b" } } }
{ anchor "foo" } { anchor "foo" }
@ -27,7 +28,8 @@ CONSTANT: urls
{ {
T{ url T{ url
{ protocol "http" } { protocol "http" }
{ addr T{ inet f "www.apple.com" 1234 } } { host "www.apple.com" }
{ port 1234 }
{ path "/another/fine/path" } { path "/another/fine/path" }
{ anchor "foo" } { anchor "foo" }
} }
@ -62,7 +64,7 @@ CONSTANT: urls
{ {
T{ url T{ url
{ protocol "ftp" } { protocol "ftp" }
{ addr T{ inet f "ftp.kernel.org" } } { host "ftp.kernel.org" }
{ username "slava" } { username "slava" }
{ path "/" } { path "/" }
} }
@ -71,7 +73,7 @@ CONSTANT: urls
{ {
T{ url T{ url
{ protocol "ftp" } { protocol "ftp" }
{ addr T{ inet f "ftp.kernel.org" } } { host "ftp.kernel.org" }
{ username "slava" } { username "slava" }
{ password "secret" } { password "secret" }
{ path "/" } { path "/" }
@ -81,7 +83,7 @@ CONSTANT: urls
{ {
T{ url T{ url
{ protocol "http" } { protocol "http" }
{ addr T{ inet f "foo.com" } } { host "foo.com" }
{ path "/" } { path "/" }
{ query H{ { "a" f } } } { query H{ { "a" f } } }
} }
@ -112,13 +114,15 @@ urls [
[ [
T{ url T{ url
{ protocol "http" } { protocol "http" }
{ addr T{ inet f "www.apple.com" 1234 } } { host "www.apple.com" }
{ port 1234 }
{ path "/a/path" } { path "/a/path" }
} }
] [ ] [
T{ url T{ url
{ protocol "http" } { protocol "http" }
{ addr T{ inet f "www.apple.com" 1234 } } { host "www.apple.com" }
{ port 1234 }
{ path "/foo" } { path "/foo" }
} }
@ -132,7 +136,8 @@ urls [
[ [
T{ url T{ url
{ protocol "http" } { protocol "http" }
{ addr T{ inet f "www.apple.com" 1234 } } { host "www.apple.com" }
{ port 1234 }
{ path "/a/path/relative/path" } { path "/a/path/relative/path" }
{ query H{ { "a" "b" } } } { query H{ { "a" "b" } } }
{ anchor "foo" } { anchor "foo" }
@ -140,7 +145,8 @@ urls [
] [ ] [
T{ url T{ url
{ protocol "http" } { protocol "http" }
{ addr T{ inet f "www.apple.com" 1234 } } { host "www.apple.com" }
{ port 1234 }
{ path "/a/path/" } { path "/a/path/" }
} }
@ -156,7 +162,8 @@ urls [
[ [
T{ url T{ url
{ protocol "http" } { protocol "http" }
{ addr T{ inet f "www.apple.com" 1234 } } { host "www.apple.com" }
{ port 1234 }
{ path "/a/path/relative/path" } { path "/a/path/relative/path" }
{ query H{ { "a" "b" } } } { query H{ { "a" "b" } } }
{ anchor "foo" } { anchor "foo" }
@ -164,7 +171,8 @@ urls [
] [ ] [
T{ url T{ url
{ protocol "http" } { protocol "http" }
{ addr T{ inet f "www.apple.com" 1234 } } { host "www.apple.com" }
{ port 1234 }
{ path "/a/path/" } { path "/a/path/" }
} }
@ -180,13 +188,13 @@ urls [
[ [
T{ url T{ url
{ protocol "http" } { protocol "http" }
{ addr T{ inet f "www.apple.com" } } { host "www.apple.com" }
{ path "/xxx/baz" } { path "/xxx/baz" }
} }
] [ ] [
T{ url T{ url
{ protocol "http" } { protocol "http" }
{ addr T{ inet f "www.apple.com" } } { host "www.apple.com" }
{ path "/xxx/bar" } { path "/xxx/bar" }
} }
@ -210,7 +218,7 @@ urls [
[ [
T{ url T{ url
{ protocol "http" } { protocol "http" }
{ addr T{ inet f "localhost" } } { host "localhost" }
{ query H{ { "foo" "bar" } } } { query H{ { "foo" "bar" } } }
{ path "/" } { path "/" }
} }
@ -220,7 +228,7 @@ urls [
[ [
T{ url T{ url
{ protocol "http" } { protocol "http" }
{ addr T{ inet f "localhost" } } { host "localhost" }
{ query H{ { "foo" "bar" } } } { query H{ { "foo" "bar" } } }
{ path "/" } { path "/" }
} }

53
basis/urls/urls.factor
View File

@ -1,13 +1,13 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays ascii assocs classes combinators USING: kernel ascii combinators combinators.short-circuit
combinators.short-circuit fry hashtables io.encodings.string sequences splitting fry namespaces make assocs arrays strings
io.encodings.utf8 io.sockets kernel lexer make math math.parser io.sockets io.encodings.string io.encodings.utf8 math
namespaces parser peg.ebnf present sequences splitting strings math.parser accessors parser strings.parser lexer
strings.parser urls.encoding ; hashtables present peg.ebnf urls.encoding ;
IN: urls IN: urls
TUPLE: url protocol username password addr path query anchor ; TUPLE: url protocol username password host port path query anchor ;
: <url> ( -- url ) url new ; : <url> ( -- url ) url new ;
@ -74,7 +74,7 @@ M: string >url
[ [
second second
[ first [ first2 [ >>username ] [ >>password ] bi* ] when* ] [ first [ first2 [ >>username ] [ >>password ] bi* ] when* ]
[ second parse-host <inet> >>addr ] bi [ second parse-host [ >>host ] [ >>port ] bi* ] bi
] bi ] bi
] when* ] when*
] ]
@ -82,17 +82,7 @@ M: string >url
[ third >>query ] [ third >>query ]
[ fourth >>anchor ] [ fourth >>anchor ]
} cleave } cleave
dup addr>> [ [ "/" or ] change-path ] when ; dup host>> [ [ "/" 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 )
{ {
@ -110,9 +100,7 @@ M: inet6 >url inet>url ;
] [ 2drop ] if ; ] [ 2drop ] if ;
: url-port ( url -- port/f ) : url-port ( url -- port/f )
[ addr>> port>> ] [ port>> ] [ port>> ] [ protocol>> protocol-port ] tri =
[ addr>> port>> ]
[ protocol>> protocol-port ] tri =
[ drop f ] when ; [ drop f ] when ;
: unparse-host-part ( url protocol -- ) : unparse-host-part ( url protocol -- )
@ -120,7 +108,7 @@ M: inet6 >url inet>url ;
"://" % "://" %
{ {
[ unparse-username-password ] [ unparse-username-password ]
[ addr>> host>> url-encode % ] [ host>> url-encode % ]
[ url-port [ ":" % # ] when* ] [ url-port [ ":" % # ] when* ]
[ path>> "/" head? [ "/" % ] unless ] [ path>> "/" head? [ "/" % ] unless ]
} cleave ; } cleave ;
@ -153,7 +141,8 @@ PRIVATE>
[ [ protocol>> ] either? >>protocol ] [ [ protocol>> ] either? >>protocol ]
[ [ username>> ] either? >>username ] [ [ username>> ] either? >>username ]
[ [ password>> ] either? >>password ] [ [ password>> ] either? >>password ]
[ [ addr>> ] either? >>addr ] [ [ host>> ] either? >>host ]
[ [ 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 ]
@ -162,7 +151,8 @@ PRIVATE>
: relative-url ( url -- url' ) : relative-url ( url -- url' )
clone clone
f >>protocol f >>protocol
f >>addr ; f >>host
f >>port ;
: relative-url? ( url -- ? ) protocol>> not ; : relative-url? ( url -- ? ) protocol>> not ;
@ -178,15 +168,18 @@ PRIVATE>
: url-addr ( url -- addr ) : url-addr ( url -- addr )
[ [
[ addr>> ] [ host>> ]
[ [ addr>> port>> ] [ protocol>> protocol-port ] bi or ] bi with-port [ port>> ]
[ protocol>> protocol-port ]
tri or <inet>
] [ protocol>> ] bi ] [ protocol>> ] bi
secure-protocol? [ >secure-addr ] when ; secure-protocol? [ >secure-addr ] when ;
: set-url-addr ( url addr -- url )
[ host>> >>host ] [ port>> >>port ] bi ;
: ensure-port ( url -- url' ) : ensure-port ( url -- url' )
clone dup protocol>> '[ clone dup protocol>> '[ _ protocol-port or ] change-port ;
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! ;