diff --git a/basis/ftp/client/client.factor b/basis/ftp/client/client.factor index 47f5e23ab9..c94d5a273a 100644 --- a/basis/ftp/client/client.factor +++ b/basis/ftp/client/client.factor @@ -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 drop ; + [ url-addr ftp-epsv parse-epsv with-port ] dip 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 drop ; + url-addr utf8 drop ; : with-ftp-client ( url quot -- ) [ [ ftp-connect ] keep ] dip diff --git a/basis/ftp/server/server-tests.factor b/basis/ftp/server/server-tests.factor index 458c92a8a1..49ffc25e0a 100644 --- a/basis/ftp/server/server-tests.factor +++ b/basis/ftp/server/server-tests.factor @@ -17,8 +17,7 @@ CONSTANT: test-file-contents "Files are so boring anymore." '[ current-temporary-directory get 0 [ - insecure-addr - >url + "ftp://localhost" >url insecure-addr set-url-addr "ftp" >>protocol create-test-file >>path @ diff --git a/basis/furnace/utilities/utilities.factor b/basis/furnace/utilities/utilities.factor index 154dbe36f2..94762d7591 100644 --- a/basis/furnace/utilities/utilities.factor +++ b/basis/furnace/utilities/utilities.factor @@ -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 ; diff --git a/basis/http/client/client-tests.factor b/basis/http/client/client-tests.factor index 2dda877a01..7a7fcffc74 100644 --- a/basis/http/client/client-tests.factor +++ b/basis/http/client/client-tests.factor @@ -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{ } } diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index b1aa0e963c..69e84001be 100644 --- a/basis/http/client/client.factor +++ b/basis/http/client/client.factor @@ -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 ; diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor index 13e369d863..f161b4276f 100644 --- a/basis/http/http-tests.factor +++ b/basis/http/http-tests.factor @@ -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 ; -[ 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 + [ ] [ 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 diff --git a/basis/http/server/redirection/redirection-tests.factor b/basis/http/server/redirection/redirection-tests.factor index 34509386e1..d502de75b0 100644 --- a/basis/http/server/redirection/redirection-tests.factor +++ b/basis/http/server/redirection/redirection-tests.factor @@ -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 [ "http" >>protocol - T{ inet f "www.apple.com" } >>addr + "www.apple.com" >>host "/xxx/bar" >>path { { "a" "b" } } >>query dup url set diff --git a/basis/http/server/remapping/remapping-docs.factor b/basis/http/server/remapping/remapping-docs.factor index 4cebfb5bb3..7531dbef85 100644 --- a/basis/http/server/remapping/remapping-docs.factor +++ b/basis/http/server/remapping/remapping-docs.factor @@ -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" diff --git a/basis/http/server/remapping/remapping.factor b/basis/http/server/remapping/remapping.factor index 4eff340204..9068b6c7d0 100644 --- a/basis/http/server/remapping/remapping.factor +++ b/basis/http/server/remapping/remapping.factor @@ -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 ; diff --git a/basis/http/server/server.factor b/basis/http/server/server.factor index 60c3cdc963..c5bc88f81f 100644 --- a/basis/http/server/server.factor +++ b/basis/http/server/server.factor @@ -82,7 +82,8 @@ upload-limit [ 200,000,000 ] initialize ] when ; : extract-host ( request -- request ) - [ ] [ url>> ] [ "host" header parse-host >>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 ) '[ diff --git a/basis/io/servers/servers-docs.factor b/basis/io/servers/servers-docs.factor index 1add7abdef..a054a836de 100644 --- a/basis/io/servers/servers-docs.factor +++ b/basis/io/servers/servers-docs.factor @@ -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." } ; diff --git a/basis/io/servers/servers.factor b/basis/io/servers/servers.factor index 917d572c93..6f598b3110 100644 --- a/basis/io/servers/servers.factor +++ b/basis/io/servers/servers.factor @@ -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 ; +> - [ addr>> ] map [ secure? not ] filter random ; +GENERIC: connect-addr ( addrspec -- addrspec ) + +M: inet4 connect-addr [ "127.0.0.1" ] dip port>> ; + +M: inet6 connect-addr [ "::1" ] dip port>> ; + +M: secure connect-addr addrspec>> connect-addr ; + +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 ] diff --git a/basis/io/sockets/sockets-tests.factor b/basis/io/sockets/sockets-tests.factor index f5bffc5dc8..9c9f677278 100644 --- a/basis/io/sockets/sockets-tests.factor +++ b/basis/io/sockets/sockets-tests.factor @@ -10,8 +10,12 @@ IN: io.sockets.tests [ T{ inet f "google.com" f } ] [ "google.com" f ] unit-test [ T{ inet f "google.com" 0 } ] [ "google.com" 0 ] unit-test -[ T{ inet4 f "8.8.8.8" 0 } ] [ "8.8.8.8" 0 ] unit-test -[ T{ inet6 f "5:5:5:5:6:6:6:6" 0 } ] [ "5:5:5:5:6:6:6:6" 0 ] unit-test +[ T{ inet f "google.com" 80 } ] [ "google.com" 0 80 with-port ] unit-test +[ T{ inet4 f "8.8.8.8" 0 } ] [ "8.8.8.8" 0 ] unit-test +[ T{ inet4 f "8.8.8.8" 53 } ] [ "8.8.8.8" 0 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 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 diff --git a/basis/io/sockets/sockets.factor b/basis/io/sockets/sockets.factor index 07c64c7e44..2a7391c36b 100644 --- a/basis/io/sockets/sockets.factor +++ b/basis/io/sockets/sockets.factor @@ -16,6 +16,8 @@ IN: io.sockets { [ os unix? ] [ "unix.ffi" ] } } cond use-vocab >> +GENERIC# with-port 1 ( addrspec port -- addrspec ) + ! Addressing -GENERIC# with-port 1 ( addrspec port -- addrspec ) - TUPLE: local { path read-only } ; : ( 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 ; - -: ( host port -- inet4 ) - [ ensure-inet4-string ] dip inet4 boa ; +C: inet4 M: ipv4 with-port [ host>> ] dip ; @@ -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 ; - -: ( host port -- inet6 ) - [ ensure-inet6-string ] dip inet6 boa ; +C: inet6 M: ipv6 with-port [ host>> ] dip ; @@ -386,23 +365,21 @@ TUPLE: inet < hostname port ; M: inet present [ host>> ] [ port>> number>string ] bi ":" glue ; -: ( host port -- inet ) - { - { [ over inet4-string? ] [ inet4 boa ] } - { [ over inet6-string? ] [ inet6 boa ] } - [ inet boa ] - } cond ; - -M: inet with-port [ host>> ] dip ; +C: inet M: string resolve-host f prepare-addrinfo f [ getaddrinfo addrinfo-error ] keep *void* addrinfo memory>struct [ parse-addrinfo-list ] keep freeaddrinfo ; +M: string with-port ; + M: hostname resolve-host host>> resolve-host ; +M: hostname with-port + [ host>> ] dip ; + M: inet resolve-host [ call-next-method ] [ port>> ] bi '[ _ with-port ] map ; diff --git a/basis/urls/urls-docs.factor b/basis/urls/urls-docs.factor index b6faa15f43..c177196786 100644 --- a/basis/urls/urls-docs.factor +++ b/basis/urls/urls-docs.factor @@ -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 diff --git a/basis/urls/urls-tests.factor b/basis/urls/urls-tests.factor index 2790c71043..f2ecd6ec69 100644 --- a/basis/urls/urls-tests.factor +++ b/basis/urls/urls-tests.factor @@ -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 \ No newline at end of file diff --git a/basis/urls/urls.factor b/basis/urls/urls.factor index e44a1dd756..7b2d2a4975 100644 --- a/basis/urls/urls.factor +++ b/basis/urls/urls.factor @@ -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 new ; @@ -74,7 +74,7 @@ M: string >url [ second [ first [ first2 [ >>username ] [ >>password ] bi* ] when* ] - [ second parse-host >>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 ; - -url ( inet -- 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 ] [ 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! ;