urls: Allow URLs of the form //foo.com, which take on the protocol of the URL they...

diff --git a/basis/urls/urls-tests.factor b/basis/urls/urls-tests.factor
index e188a1c64572466cba6e51f7a0fc62d618210d4d..e196161e9b2dad82119f115c1d4423c18d55b62d 100644 (file)
--- a/basis/urls/urls-tests.factor
+++ b/basis/urls/urls-tests.factor
@@ -225,6 +225,13 @@ urls [
     derive-url
 ] unit-test
 
+! Support //foo.com, which has the same protocol as the url we derive from
+[ URL" http://foo.com" ]
+[ URL" http://google.com" URL" //foo.com" derive-url ] unit-test
+
+[ URL" https://foo.com" ]
+[ URL" https://google.com" URL" //foo.com" derive-url ] unit-test
+
 [ "a" ] [
     <url> "a" "b" set-query-param "b" query-param
 ] unit-test
@@ -257,4 +264,4 @@ urls [
 
 [ "/" ] [ "http://www.jedit.org" >url path>> ] unit-test
 
-[ "USING: urls ;\nURL\" foo\"" ] [ URL" foo" unparse-use ] unit-test
\ No newline at end of file
+[ "USING: urls ;\nURL\" foo\"" ] [ URL" foo" unparse-use ] unit-test

diff --git a/basis/urls/urls.factor b/basis/urls/urls.factor
index 66e6ee01eb4ec703af0619412d3363aa431fa126..2e1f98080662dab2e3329e0f26c063db928fdd2e 100644 (file)
--- a/basis/urls/urls.factor
+++ b/basis/urls/urls.factor
@@ -57,7 +57,8 @@ hostname-spec = hostname ("/"|!(.)) => [[ first ]]
 auth     = (username (":" password  => [[ second ]])? "@"
                                     => [[ first2 2array ]])?
 
-url      = ((protocol "://")        => [[ first ]] auth hostname)?
+url      = (((protocol "://") => [[ first ]] auth hostname)
+                    | (("//") => [[ f ]] auth hostname))?
            (pathname)?
            ("?" query               => [[ second ]])?
            ("#" anchor              => [[ second ]])?
@@ -106,9 +107,7 @@ M: pathname >url string>> >url ;
     [ port>> ] [ port>> ] [ protocol>> protocol-port ] tri =
     [ drop f ] when ;
 
-: unparse-host-part ( url protocol -- )
-    %
-    "://" %
+: unparse-host-part ( url -- )
     {
         [ unparse-username-password ]
         [ host>> url-encode % ]
@@ -116,10 +115,22 @@ M: pathname >url string>> >url ;
         [ path>> "/" head? [ "/" % ] unless ]
     } cleave ;
 
+! URL" //foo.com" takes on the protocol of the url it's derived from
+: unparse-protocol ( url -- )
+    dup protocol>> [
+        % "://" % unparse-host-part
+    ] [
+        dup host>> [
+            "//" % unparse-host-part
+        ] [
+            drop
+        ] if
+    ] if* ;
+
 M: url present
     [
         {
-            [ dup protocol>> dup [ unparse-host-part ] [ 2drop ] if ]
+            [ unparse-protocol ]
             [ path>> url-encode % ]
             [ query>> dup assoc-empty? [ drop ] [ "?" % assoc>query % ] if ]
             [ anchor>> [ "#" % present url-encode % ] when* ]