http.client, request-url don't try to fix unfixable urls

Before, it would prepend http:// to anything and that would create
bad urls like URL" http://http://". It's simpler to fix only what is
fixable

diff --git a/basis/http/client/client-tests.factor b/basis/http/client/client-tests.factor
index 7cda571681e84b214d9484b93904a7cdc12a2088..0f4a36fb7b9283ef91aad0ee7ded0b9cd5f9b8a7 100644 (file)
--- a/basis/http/client/client-tests.factor
+++ b/basis/http/client/client-tests.factor
@@ -208,3 +208,14 @@ CONSTANT: classic-proxy-settings H{
        "http://www.google.com" "GET" <client-request> ?default-proxy
     ] with-variable
 ] [ invalid-proxy? ] must-fail-with
+
+! This url is misparsed bu request-url can fix it
+{ T{ url
+   { protocol "http" }
+   { host "www.google.com" }
+   { path "/" }
+   { port 80 }
+} } [ "www.google.com" request-url ] unit-test
+
+! This one is not fixable, leave it as it is
+{ T{ url } } [ "" request-url ] unit-test

diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor
index 57c32785f508f949d0cb7159e991f910e6cbaa47..b439d313843feab1339b5a66d87b7420fbad1e80 100644 (file)
--- a/basis/http/client/client.factor
+++ b/basis/http/client/client.factor
@@ -237,11 +237,15 @@ SYMBOL: redirects
         [ do-redirect ] [ nip ] if
     ] with-variable ; inline recursive
 
+: misparsed-url? ( url -- url' )
+    [ protocol>> not ] [ host>> not ] [ path>> ]
+    tri and and ;
+
 : request-url ( url -- url' )
-    dup >url dup protocol>> [ nip ] [
+    dup >url dup misparsed-url? [
         drop dup url? [ present ] when
         "http://" prepend >url
-    ] if ensure-port ;
+    ] [ nip ] if ensure-port ;
 
 : <client-request> ( url method -- request )
     <request>