From ba68a3732dbc1bdf5becc0db03e2ea2a2e54d054 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jjjj.local>
Date: Mon, 14 Jan 2008 15:49:13 -1000
Subject: [PATCH] better support for http-get redirects

---
 extra/http/client/client.factor | 15 ++++++++++-----
 1 file changed, 10 insertions(+), 5 deletions(-)

diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor
index f117a4fda1..7c385c0bb3 100644
--- a/extra/http/client/client.factor
+++ b/extra/http/client/client.factor
@@ -9,11 +9,14 @@ IN: http.client
     #! Extract the host name and port number from an HTTP URL.
     ":" split1 [ string>number ] [ 80 ] if* ;
 
+SYMBOL: domain
+
 : parse-url ( url -- host resource )
-    "http://" ?head [
-        "URL must begin with http://" throw
-    ] unless
-    "/" split1 [ "/" swap append ] [ "/" ] if* ;
+    dup "https://" head? [
+        "ssl not yet supported: " swap append throw
+    ] when "http://" ?head drop
+    "/" split1 [ "/" swap append ] [ "/" ] if*
+    >r dup empty? [ drop domain get ] [ dup domain set ] if r> ;
 
 : parse-response ( line -- code )
     "HTTP/" ?head [ " " split1 nip ] when
@@ -52,7 +55,9 @@ DEFER: http-get-stream
 
 : http-get ( url -- code headers string )
     #! Opens a stream for reading from an HTTP URL.
-    http-get-stream [ stdio get contents ] with-stream ;
+    [
+        http-get-stream [ stdio get contents ] with-stream
+    ] with-scope ;
 
 : download ( url file -- )
     #! Downloads the contents of a URL to a file.