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 addressesdb4
Slava Pestov
parent
4376173e83
commit
89ae9d9638
|
|
@ -61,7 +61,7 @@ ERROR: ftp-error got expected ;
|
|||
strings>> first "|" split 2 tail* first string>number ;
|
||||
|
||||
: 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 )
|
||||
utf8 open-passive-client
|
||||
|
|
@ -84,7 +84,7 @@ ERROR: ftp-error got expected ;
|
|||
ftp-set-binary 200 ftp-assert ;
|
||||
|
||||
: ftp-connect ( url -- stream )
|
||||
addr>> utf8 <client> drop ;
|
||||
url-addr utf8 <client> drop ;
|
||||
|
||||
: with-ftp-client ( url quot -- )
|
||||
[ [ ftp-connect ] keep ] dip
|
||||
|
|
|
|||
|
|
@ -17,8 +17,7 @@ CONSTANT: test-file-contents "Files are so boring anymore."
|
|||
'[
|
||||
current-temporary-directory get
|
||||
0 <ftp-server> [
|
||||
insecure-addr
|
||||
>url
|
||||
"ftp://localhost" >url insecure-addr set-url-addr
|
||||
"ftp" >>protocol
|
||||
create-test-file >>path
|
||||
@
|
||||
|
|
|
|||
|
|
@ -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-addr ] change-addr ] when ;
|
||||
dup [ >url ensure-port [ remap-port ] change-port ] when ;
|
||||
|
||||
: user-agent ( -- user-agent )
|
||||
"user-agent" request get header>> at "" or ;
|
||||
|
|
@ -105,7 +105,9 @@ CONSTANT: nested-forms-key "__n"
|
|||
dup [
|
||||
url get [
|
||||
[ protocol>> ]
|
||||
[ addr>> remap-addr ] bi 2array
|
||||
[ host>> ]
|
||||
[ port>> remap-port ]
|
||||
tri 3array
|
||||
] bi@ =
|
||||
] when ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: http.client http.client.private http tools.test
|
||||
namespaces urls io.sockets ;
|
||||
namespaces urls ;
|
||||
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" } { 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" }
|
||||
{ version "1.1" }
|
||||
{ cookies V{ } }
|
||||
|
|
@ -26,7 +26,7 @@ IN: http.client.tests
|
|||
|
||||
[
|
||||
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" }
|
||||
{ version "1.1" }
|
||||
{ cookies V{ } }
|
||||
|
|
|
|||
|
|
@ -24,13 +24,13 @@ ERROR: too-many-redirects ;
|
|||
|
||||
: default-port? ( url -- ? )
|
||||
{
|
||||
[ addr>> port>> not ]
|
||||
[ [ addr>> port>> ] [ protocol>> protocol-port ] bi = ]
|
||||
[ port>> not ]
|
||||
[ [ port>> ] [ protocol>> protocol-port ] bi = ]
|
||||
} 1|| ;
|
||||
|
||||
: unparse-host ( url -- string )
|
||||
dup default-port? [ addr>> host>> ] [
|
||||
[ addr>> host>> ] [ addr>> port>> number>string ] bi ":" glue
|
||||
dup default-port? [ host>> ] [
|
||||
[ host>> ] [ 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>> addr>> host>> [ set-host-header ] when
|
||||
over url>> host>> [ set-host-header ] when
|
||||
over post-data>> [ set-post-data-headers ] when*
|
||||
over cookies>> [ set-cookie-header ] unless-empty
|
||||
write-header ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
arrays splitting sequences assocs io.sockets db db.sqlite
|
||||
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
|
||||
|
||||
[ "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" 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" } { 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
|
||||
[ "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
|
||||
|
||||
: lf>crlf ( string -- string' ) "\n" split "\r\n" join ;
|
||||
|
||||
|
|
@ -37,7 +39,7 @@ blah
|
|||
|
||||
[
|
||||
T{ request
|
||||
{ url T{ url { path "/bar" } { addr T{ inet } } } }
|
||||
{ url T{ url { path "/bar" } } }
|
||||
{ method "POST" }
|
||||
{ version "1.1" }
|
||||
{ header H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } } }
|
||||
|
|
@ -76,7 +78,7 @@ Host: www.sex.com
|
|||
|
||||
[
|
||||
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" }
|
||||
{ version "1.1" }
|
||||
{ header H{ { "host" "www.sex.com" } } }
|
||||
|
|
@ -97,7 +99,7 @@ Host: www.sex.com:101
|
|||
|
||||
[
|
||||
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" }
|
||||
{ version "1.1" }
|
||||
{ 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-file delete-file ] ignore-errors
|
||||
|
||||
test-db [
|
||||
init-furnace-tables
|
||||
] with-db
|
||||
|
||||
: test-httpd ( responder -- )
|
||||
[
|
||||
main-responder set
|
||||
|
|
@ -232,16 +228,25 @@ test-db [
|
|||
0 >>insecure
|
||||
f >>secure
|
||||
start-server
|
||||
servers>> random addr>>
|
||||
threaded-server set
|
||||
server-addrs random
|
||||
] with-scope "addr" set ;
|
||||
|
||||
: add-addr ( url -- url' )
|
||||
>url clone "addr" get >>addr ;
|
||||
>url clone "addr" get set-url-addr ;
|
||||
|
||||
: stop-test-httpd ( -- )
|
||||
"http://localhost/quit" add-addr http-get nip
|
||||
"Goodbye" assert= ;
|
||||
|
||||
[ ] [
|
||||
[ test-db-file delete-file ] ignore-errors
|
||||
|
||||
test-db [
|
||||
init-furnace-tables
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
<dispatcher>
|
||||
add-quit-action
|
||||
|
|
@ -281,6 +286,7 @@ test-db [
|
|||
"http://localhost/redirect" add-addr http-get nip
|
||||
] unit-test
|
||||
|
||||
|
||||
[ ] [
|
||||
[ stop-test-httpd ] ignore-errors
|
||||
] unit-test
|
||||
|
|
@ -301,7 +307,12 @@ test-db [
|
|||
test-httpd
|
||||
] 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
|
||||
[ "http://localhost/d/blah" add-addr http-get nip ] [ 404? ] must-fail-with
|
||||
|
|
|
|||
|
|
@ -1,12 +1,12 @@
|
|||
USING: accessors http http.server.redirection io.sockets kernel
|
||||
namespaces present tools.test urls ;
|
||||
USING: http http.server.redirection urls accessors
|
||||
namespaces tools.test present kernel ;
|
||||
IN: http.server.redirection.tests
|
||||
|
||||
[
|
||||
<request>
|
||||
<url>
|
||||
"http" >>protocol
|
||||
T{ inet f "www.apple.com" } >>addr
|
||||
"www.apple.com" >>host
|
||||
"/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
|
||||
"{ { 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"
|
||||
|
|
|
|||
|
|
@ -1,12 +1,12 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||
! 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
|
||||
|
||||
SYMBOL: port-remapping
|
||||
|
||||
: remap-addr ( addr -- addr' )
|
||||
: remap-port ( n -- n' )
|
||||
[ port-remapping get at ] keep or ;
|
||||
|
||||
: secure-http-port ( -- addr )
|
||||
secure-addr remap-addr ;
|
||||
: secure-http-port ( -- n )
|
||||
secure-addr port>> remap-port ;
|
||||
|
|
|
|||
|
|
@ -82,7 +82,8 @@ upload-limit [ 200,000,000 ] initialize
|
|||
] when ;
|
||||
|
||||
: extract-host ( request -- request )
|
||||
[ ] [ url>> ] [ "host" header parse-host <inet> >>addr ] tri
|
||||
[ ] [ url>> ] [ "host" header parse-host ] tri
|
||||
[ >>host ] [ >>port ] bi*
|
||||
drop ;
|
||||
|
||||
: extract-cookies ( request -- request )
|
||||
|
|
@ -115,7 +116,7 @@ GENERIC: write-full-response ( request response -- )
|
|||
|
||||
: ensure-domain ( cookie -- cookie )
|
||||
[
|
||||
url get addr>> host>> dup "localhost" =
|
||||
url get host>> dup "localhost" =
|
||||
[ drop ] [ or ] if
|
||||
] change-domain ;
|
||||
|
||||
|
|
@ -250,12 +251,13 @@ SYMBOL: params
|
|||
[
|
||||
local-address get
|
||||
[ secure? "https" "http" ? >>protocol ]
|
||||
[ remap-addr '[ _ or ] change-addr ] bi
|
||||
[ port>> remap-port '[ _ or ] change-port ]
|
||||
bi
|
||||
] change-url drop ;
|
||||
|
||||
: valid-request? ( request -- ? )
|
||||
url>> addr>> remap-addr
|
||||
local-address get remap-addr = ;
|
||||
url>> port>> remap-port
|
||||
local-address get port>> remap-port = ;
|
||||
|
||||
: do-request ( request -- response )
|
||||
'[
|
||||
|
|
|
|||
|
|
@ -126,11 +126,11 @@ HELP: with-threaded-server
|
|||
{ $description "Runs a server and calls a quotation, stopping the server once the quotation returns." } ;
|
||||
|
||||
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." }
|
||||
{ $notes "Can only be used from the dynamic scope of a " { $link handle-client* } " call." } ;
|
||||
|
||||
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." }
|
||||
{ $notes "Can only be used from the dynamic scope of a " { $link handle-client* } " call." } ;
|
||||
|
|
|
|||
|
|
@ -162,7 +162,8 @@ ERROR: no-ports-configured threaded-server ;
|
|||
|
||||
: set-servers ( threaded-server -- threaded-server )
|
||||
dup [
|
||||
dup dup listen-on [ no-ports-configured ] [ (make-servers) ] if-empty
|
||||
dup dup listen-on
|
||||
[ no-ports-configured ] [ (make-servers) ] if-empty
|
||||
>>servers
|
||||
] with-existing-secure-context ;
|
||||
|
||||
|
|
@ -219,13 +220,26 @@ PRIVATE>
|
|||
[ ] cleanup
|
||||
] call ; inline
|
||||
|
||||
: secure-addr ( -- inet/f )
|
||||
threaded-server get servers>>
|
||||
[ addr>> ] map [ secure? ] filter random ;
|
||||
<PRIVATE
|
||||
|
||||
: insecure-addr ( -- inet/f )
|
||||
threaded-server get servers>>
|
||||
[ addr>> ] map [ secure? not ] filter random ;
|
||||
GENERIC: connect-addr ( addrspec -- addrspec )
|
||||
|
||||
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 -- )
|
||||
[ [ "=== " write name>> ] [ ] bi write-object nl ]
|
||||
|
|
|
|||
|
|
@ -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" 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
|
||||
[ T{ inet f "google.com" 80 } ] [ "google.com" 0 <inet> 80 with-port ] 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 } ]
|
||||
[ "1.2.3.4" T{ inet4 } inet-pton ] unit-test
|
||||
|
|
|
|||
|
|
@ -16,6 +16,8 @@ IN: io.sockets
|
|||
{ [ os unix? ] [ "unix.ffi" ] }
|
||||
} cond use-vocab >>
|
||||
|
||||
GENERIC# with-port 1 ( addrspec port -- addrspec )
|
||||
|
||||
! Addressing
|
||||
<PRIVATE
|
||||
|
||||
|
|
@ -53,8 +55,6 @@ HOOK: addrspec-of-family os ( af -- addrspec )
|
|||
|
||||
PRIVATE>
|
||||
|
||||
GENERIC# with-port 1 ( addrspec port -- addrspec )
|
||||
|
||||
TUPLE: local { path read-only } ;
|
||||
|
||||
: <local> ( path -- addrspec )
|
||||
|
|
@ -113,18 +113,7 @@ M: ipv4 parse-sockaddr ( sockaddr-in addrspec -- newaddrspec )
|
|||
|
||||
TUPLE: inet4 < ipv4 { port integer read-only } ;
|
||||
|
||||
: 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 ;
|
||||
C: <inet4> inet4
|
||||
|
||||
M: ipv4 with-port [ host>> ] dip <inet4> ;
|
||||
|
||||
|
|
@ -176,13 +165,11 @@ ERROR: more-than-8-components ;
|
|||
|
||||
PRIVATE>
|
||||
|
||||
ERROR: empty-ipv6 ;
|
||||
|
||||
M: ipv6 inet-pton ( str addrspec -- data )
|
||||
drop [
|
||||
[ empty-ipv6 ]
|
||||
[ "::" split1 [ parse-ipv6 ] bi@ pad-ipv6 ipv6-bytes ] if-empty
|
||||
] [ invalid-ipv6 ] recover ;
|
||||
drop
|
||||
[ "::" split1 [ parse-ipv6 ] bi@ pad-ipv6 ipv6-bytes ]
|
||||
[ invalid-ipv6 ]
|
||||
recover ;
|
||||
|
||||
M: ipv6 address-size drop 16 ;
|
||||
|
||||
|
|
@ -205,15 +192,7 @@ M: ipv6 parse-sockaddr
|
|||
|
||||
TUPLE: inet6 < ipv6 { port integer read-only } ;
|
||||
|
||||
: 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 ;
|
||||
C: <inet6> inet6
|
||||
|
||||
M: ipv6 with-port [ host>> ] dip <inet6> ;
|
||||
|
||||
|
|
@ -386,23 +365,21 @@ TUPLE: inet < hostname port ;
|
|||
M: inet present
|
||||
[ host>> ] [ port>> number>string ] bi ":" glue ;
|
||||
|
||||
: <inet> ( host port -- inet )
|
||||
{
|
||||
{ [ over inet4-string? ] [ inet4 boa ] }
|
||||
{ [ over inet6-string? ] [ inet6 boa ] }
|
||||
[ inet boa ]
|
||||
} cond ;
|
||||
|
||||
M: inet with-port [ host>> ] dip <inet> ;
|
||||
C: <inet> inet
|
||||
|
||||
M: string resolve-host
|
||||
f prepare-addrinfo f <void*>
|
||||
[ getaddrinfo addrinfo-error ] keep *void* addrinfo memory>struct
|
||||
[ parse-addrinfo-list ] keep freeaddrinfo ;
|
||||
|
||||
M: string with-port <inet> ;
|
||||
|
||||
M: hostname resolve-host
|
||||
host>> resolve-host ;
|
||||
|
||||
M: hostname with-port
|
||||
[ host>> ] dip <inet> ;
|
||||
|
||||
M: inet resolve-host
|
||||
[ call-next-method ] [ port>> ] bi '[ _ with-port ] map ;
|
||||
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@ HELP: >url
|
|||
"We can examine the URL object:"
|
||||
{ $example
|
||||
"USING: accessors io urls ;"
|
||||
"\"http://www.apple.com\" >url addr>> host>> print"
|
||||
"\"http://www.apple.com\" >url 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\" addr>> port>> ."
|
||||
"URL\" http://factorcode.org:80\" port>> ."
|
||||
"80"
|
||||
}
|
||||
} ;
|
||||
|
|
@ -70,13 +70,13 @@ HELP: ensure-port
|
|||
{ $examples
|
||||
{ $example
|
||||
"USING: accessors prettyprint urls ;"
|
||||
"URL\" https://concatenative.org\" ensure-port addr>> port>> ."
|
||||
"URL\" https://concatenative.org\" ensure-port port>> ."
|
||||
"443"
|
||||
}
|
||||
} ;
|
||||
|
||||
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 } "." }
|
||||
{ $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,13 +1,14 @@
|
|||
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" }
|
||||
{ addr T{ inet f "www.apple.com" 1234 } }
|
||||
{ host "www.apple.com" }
|
||||
{ port 1234 }
|
||||
{ path "/a/path" }
|
||||
{ query H{ { "a" "b" } } }
|
||||
{ anchor "foo" }
|
||||
|
|
@ -17,7 +18,7 @@ CONSTANT: urls
|
|||
{
|
||||
T{ url
|
||||
{ protocol "http" }
|
||||
{ addr T{ inet f "www.apple.com" } }
|
||||
{ host "www.apple.com" }
|
||||
{ path "/a/path" }
|
||||
{ query H{ { "a" "b" } } }
|
||||
{ anchor "foo" }
|
||||
|
|
@ -27,7 +28,8 @@ CONSTANT: urls
|
|||
{
|
||||
T{ url
|
||||
{ protocol "http" }
|
||||
{ addr T{ inet f "www.apple.com" 1234 } }
|
||||
{ host "www.apple.com" }
|
||||
{ port 1234 }
|
||||
{ path "/another/fine/path" }
|
||||
{ anchor "foo" }
|
||||
}
|
||||
|
|
@ -62,7 +64,7 @@ CONSTANT: urls
|
|||
{
|
||||
T{ url
|
||||
{ protocol "ftp" }
|
||||
{ addr T{ inet f "ftp.kernel.org" } }
|
||||
{ host "ftp.kernel.org" }
|
||||
{ username "slava" }
|
||||
{ path "/" }
|
||||
}
|
||||
|
|
@ -71,7 +73,7 @@ CONSTANT: urls
|
|||
{
|
||||
T{ url
|
||||
{ protocol "ftp" }
|
||||
{ addr T{ inet f "ftp.kernel.org" } }
|
||||
{ host "ftp.kernel.org" }
|
||||
{ username "slava" }
|
||||
{ password "secret" }
|
||||
{ path "/" }
|
||||
|
|
@ -81,7 +83,7 @@ CONSTANT: urls
|
|||
{
|
||||
T{ url
|
||||
{ protocol "http" }
|
||||
{ addr T{ inet f "foo.com" } }
|
||||
{ host "foo.com" }
|
||||
{ path "/" }
|
||||
{ query H{ { "a" f } } }
|
||||
}
|
||||
|
|
@ -112,13 +114,15 @@ urls [
|
|||
[
|
||||
T{ url
|
||||
{ protocol "http" }
|
||||
{ addr T{ inet f "www.apple.com" 1234 } }
|
||||
{ host "www.apple.com" }
|
||||
{ port 1234 }
|
||||
{ path "/a/path" }
|
||||
}
|
||||
] [
|
||||
T{ url
|
||||
{ protocol "http" }
|
||||
{ addr T{ inet f "www.apple.com" 1234 } }
|
||||
{ host "www.apple.com" }
|
||||
{ port 1234 }
|
||||
{ path "/foo" }
|
||||
}
|
||||
|
||||
|
|
@ -132,7 +136,8 @@ urls [
|
|||
[
|
||||
T{ url
|
||||
{ protocol "http" }
|
||||
{ addr T{ inet f "www.apple.com" 1234 } }
|
||||
{ host "www.apple.com" }
|
||||
{ port 1234 }
|
||||
{ path "/a/path/relative/path" }
|
||||
{ query H{ { "a" "b" } } }
|
||||
{ anchor "foo" }
|
||||
|
|
@ -140,7 +145,8 @@ urls [
|
|||
] [
|
||||
T{ url
|
||||
{ protocol "http" }
|
||||
{ addr T{ inet f "www.apple.com" 1234 } }
|
||||
{ host "www.apple.com" }
|
||||
{ port 1234 }
|
||||
{ path "/a/path/" }
|
||||
}
|
||||
|
||||
|
|
@ -156,7 +162,8 @@ urls [
|
|||
[
|
||||
T{ url
|
||||
{ protocol "http" }
|
||||
{ addr T{ inet f "www.apple.com" 1234 } }
|
||||
{ host "www.apple.com" }
|
||||
{ port 1234 }
|
||||
{ path "/a/path/relative/path" }
|
||||
{ query H{ { "a" "b" } } }
|
||||
{ anchor "foo" }
|
||||
|
|
@ -164,7 +171,8 @@ urls [
|
|||
] [
|
||||
T{ url
|
||||
{ protocol "http" }
|
||||
{ addr T{ inet f "www.apple.com" 1234 } }
|
||||
{ host "www.apple.com" }
|
||||
{ port 1234 }
|
||||
{ path "/a/path/" }
|
||||
}
|
||||
|
||||
|
|
@ -180,13 +188,13 @@ urls [
|
|||
[
|
||||
T{ url
|
||||
{ protocol "http" }
|
||||
{ addr T{ inet f "www.apple.com" } }
|
||||
{ host "www.apple.com" }
|
||||
{ path "/xxx/baz" }
|
||||
}
|
||||
] [
|
||||
T{ url
|
||||
{ protocol "http" }
|
||||
{ addr T{ inet f "www.apple.com" } }
|
||||
{ host "www.apple.com" }
|
||||
{ path "/xxx/bar" }
|
||||
}
|
||||
|
||||
|
|
@ -210,7 +218,7 @@ urls [
|
|||
[
|
||||
T{ url
|
||||
{ protocol "http" }
|
||||
{ addr T{ inet f "localhost" } }
|
||||
{ host "localhost" }
|
||||
{ query H{ { "foo" "bar" } } }
|
||||
{ path "/" }
|
||||
}
|
||||
|
|
@ -220,7 +228,7 @@ urls [
|
|||
[
|
||||
T{ url
|
||||
{ protocol "http" }
|
||||
{ addr T{ inet f "localhost" } }
|
||||
{ host "localhost" }
|
||||
{ query H{ { "foo" "bar" } } }
|
||||
{ path "/" }
|
||||
}
|
||||
|
|
@ -229,4 +237,4 @@ urls [
|
|||
|
||||
[ "/" ] [ "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
|
||||
|
|
@ -1,13 +1,13 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
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 ;
|
||||
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 ;
|
||||
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 ;
|
||||
|
||||
|
|
@ -74,7 +74,7 @@ M: string >url
|
|||
[
|
||||
second
|
||||
[ first [ first2 [ >>username ] [ >>password ] bi* ] when* ]
|
||||
[ second parse-host <inet> >>addr ] bi
|
||||
[ second parse-host [ >>host ] [ >>port ] bi* ] bi
|
||||
] bi
|
||||
] when*
|
||||
]
|
||||
|
|
@ -82,17 +82,7 @@ M: string >url
|
|||
[ 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 ;
|
||||
dup host>> [ [ "/" or ] change-path ] when ;
|
||||
|
||||
: protocol-port ( protocol -- port )
|
||||
{
|
||||
|
|
@ -110,9 +100,7 @@ M: inet6 >url inet>url ;
|
|||
] [ 2drop ] if ;
|
||||
|
||||
: url-port ( url -- port/f )
|
||||
[ addr>> port>> ]
|
||||
[ addr>> port>> ]
|
||||
[ protocol>> protocol-port ] tri =
|
||||
[ port>> ] [ port>> ] [ protocol>> protocol-port ] tri =
|
||||
[ drop f ] when ;
|
||||
|
||||
: unparse-host-part ( url protocol -- )
|
||||
|
|
@ -120,7 +108,7 @@ M: inet6 >url inet>url ;
|
|||
"://" %
|
||||
{
|
||||
[ unparse-username-password ]
|
||||
[ addr>> host>> url-encode % ]
|
||||
[ host>> url-encode % ]
|
||||
[ url-port [ ":" % # ] when* ]
|
||||
[ path>> "/" head? [ "/" % ] unless ]
|
||||
} cleave ;
|
||||
|
|
@ -153,7 +141,8 @@ PRIVATE>
|
|||
[ [ protocol>> ] either? >>protocol ]
|
||||
[ [ username>> ] either? >>username ]
|
||||
[ [ password>> ] either? >>password ]
|
||||
[ [ addr>> ] either? >>addr ]
|
||||
[ [ host>> ] either? >>host ]
|
||||
[ [ port>> ] either? >>port ]
|
||||
[ [ path>> ] bi@ swap url-append-path >>path ]
|
||||
[ [ query>> ] either? >>query ]
|
||||
[ [ anchor>> ] either? >>anchor ]
|
||||
|
|
@ -162,7 +151,8 @@ PRIVATE>
|
|||
: relative-url ( url -- url' )
|
||||
clone
|
||||
f >>protocol
|
||||
f >>addr ;
|
||||
f >>host
|
||||
f >>port ;
|
||||
|
||||
: relative-url? ( url -- ? ) protocol>> not ;
|
||||
|
||||
|
|
@ -178,15 +168,18 @@ PRIVATE>
|
|||
|
||||
: url-addr ( url -- addr )
|
||||
[
|
||||
[ addr>> ]
|
||||
[ [ addr>> port>> ] [ protocol>> protocol-port ] bi or ] bi with-port
|
||||
[ host>> ]
|
||||
[ port>> ]
|
||||
[ protocol>> protocol-port ]
|
||||
tri or <inet>
|
||||
] [ protocol>> ] bi
|
||||
secure-protocol? [ >secure-addr ] when ;
|
||||
|
||||
: set-url-addr ( url addr -- url )
|
||||
[ host>> >>host ] [ port>> >>port ] bi ;
|
||||
|
||||
: ensure-port ( url -- url' )
|
||||
clone dup protocol>> '[
|
||||
dup port>> _ protocol-port or with-port
|
||||
] change-addr ;
|
||||
clone dup protocol>> '[ _ protocol-port or ] change-port ;
|
||||
|
||||
! Literal syntax
|
||||
SYNTAX: URL" lexer get skip-blank parse-string >url suffix! ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue