]> gitweb.factorcode.org Git - factor.git/commitdiff
Various cleanups for Doug's recent socket addressing change
authorSlava Pestov <slava@slava-pestovs-macbook-pro.local>
Thu, 7 Oct 2010 06:00:38 +0000 (23:00 -0700)
committerSlava Pestov <slava@slava-pestovs-macbook-pro.local>
Thu, 7 Oct 2010 06:00:38 +0000 (23:00 -0700)
- urls: now have a host/port slots again, add a new set-url-addr word
- http.server: fix host header parsing for IPv6 addresses

17 files changed:
basis/ftp/client/client.factor
basis/ftp/server/server-tests.factor
basis/furnace/utilities/utilities.factor
basis/http/client/client-tests.factor
basis/http/client/client.factor
basis/http/http-tests.factor
basis/http/server/redirection/redirection-tests.factor
basis/http/server/remapping/remapping-docs.factor
basis/http/server/remapping/remapping.factor
basis/http/server/server.factor
basis/io/servers/servers-docs.factor
basis/io/servers/servers.factor
basis/io/sockets/sockets-tests.factor
basis/io/sockets/sockets.factor
basis/urls/urls-docs.factor
basis/urls/urls-tests.factor
basis/urls/urls.factor

index 47f5e23ab966aace3bc45aa5c367bb4293c7b5c9..c94d5a273a20bbc46e4774c61d3d606d47002acc 100644 (file)
@@ -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
index 458c92a8a16951c163ada21c487b431a65e9a504..49ffc25e0ab8d007807679dc5a4e197432790754 100644 (file)
@@ -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
                 @
index 154dbe36f2ff4bea2d9088d7604b2254b5e2ee46..94762d7591c13b30c3c58275c714bb08de624178 100644 (file)
@@ -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 ;
 
index 2dda877a0134601b4d223a1eab098facf766eecb..7a7fcffc741d5a838971d0a9a4e4018a8cbf0209 100644 (file)
@@ -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{ } }
index b1aa0e963c7ea66b455aa7df4e54f6b43eb8eb87..69e84001beb1a5a429dcc623167046d397be4e3a 100644 (file)
@@ -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 ;
index 13e369d86302380f5ea852bdcf467ba349f9a93f..f161b4276f0589c497d512db86631411da56c891 100644 (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
 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
index 34509386e1722a4e1d7d88c5bcfbdfb21243a1a8..d502de75b0e6d9779c9fee15d24af513cf0db190 100644 (file)
@@ -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
index 4cebfb5bb389b79cfd1485067d8420b53ad46738..7531dbef85acba06e7a33f50a4c81b849c70a6a2 100644 (file)
@@ -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"
index 4eff34020470edbbf10ca2e6409096a68af09931..9068b6c7d047bbd6275fc0ef2379aa864efcd3a9 100644 (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.
-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 ;
index 60c3cdc96327f69521b58ba626a7eacb789b67a5..c5bc88f81f840724845d370708157246488fb3d6 100644 (file)
@@ -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 )
     '[
index 1add7abdef48e206b77826d47ce6ec0ac504e4ab..a054a836dea0240a14d8c06abb9256bbc64c2905 100644 (file)
@@ -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." } ;
index 917d572c933e376c9333aa6af38747136abbdeb6..6f598b3110a39b40ca81a55ef1365d5d1a05d8db 100644 (file)
@@ -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
+
+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 ( -- inet/f )
-    threaded-server get servers>>
-    [ addr>> ] map [ secure? not ] filter random ;
+: insecure-addr ( -- addrspec )
+    server-addrs [ secure? not ] filter random ;
     
 : server. ( threaded-server -- )
     [ [ "=== " write name>> ] [ ] bi write-object nl ]
index f5bffc5dc8c2ee08dadaa4a4bb87e6d1c0fdbdd3..9c9f6772786ca3a93462ab463cb0de14ec521f59 100644 (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" 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
index 07c64c7e44abb61ec3f61f29b6bee736fe2d21e7..2a7391c36b2514f2f641fe79eaa2d84807e09581 100644 (file)
@@ -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 ;
 
index b6faa15f43595bcc20a4da2137771bf5c8bdaa7b..c177196786e534f72304757c00f8fa3654842e26 100644 (file)
@@ -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
index 2790c7104376af32ecf8be64c68346f465d119dc..f2ecd6ec6921d0ecf6e6883e7b875c52865cd482 100644 (file)
@@ -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
index e44a1dd756a05ed453a00d498acf1971af34fd7c..7b2d2a49754e754a29923b5136877cb5b7beed1a 100644 (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.
-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! ;