r529 - ofw/inetv6

Author: lwalter
Date: 2007-08-06 20:37:01 +0200 (Mon, 06 Aug 2007)
New Revision: 529

Modified:
   ofw/inetv6/http.fth
Log:
Support redirect and http-proxy

Modified: ofw/inetv6/http.fth
===================================================================
--- ofw/inetv6/http.fth	2007-08-06 18:26:17 UTC (rev 528)
+++ ofw/inetv6/http.fth	2007-08-06 18:37:01 UTC (rev 529)
@@ -5,6 +5,42 @@

false instance value debug?

+h# 100 instance buffer: url
+0      instance value   /url
+h# 80  instance buffer: proxy
+0      instance value   /proxy
+
+-1 value result-code
+0  value image-size
+
+\ proxy should have the value of
+\   1.  environment variable, http-proxy, if not null$
+\   2.  otherwise, devalias http-proxy, if not null$
+\   3.  Location: URL$ for status code 305
+
+: set-proxy  ( $ -- )
+   \ strip "http://" or "http:\"
+   over " http:" comp 0=  if
+      7 /string
+   else
+      over " HTTP:" comp 0=  if  7 /string  then
+   then
+
+   dup to /proxy  proxy swap move  
+;
+: init-proxy  ( -- )
+   0 to /proxy
+   " http-proxy" $getenv 0=  if
+      ?dup  if
+         set-proxy
+         exit
+      else
+         drop
+      then
+   then
+   " http-proxy" not-alias? 0=  if  set-proxy  then
+;
+
 d# 255 instance buffer: pathbuf
 : fix-delims  ( $ -- $' )
    pathbuf pack count   ( $' )
@@ -117,21 +153,17 @@

: decode-url  ( url$ -- send$ prefix$ port# server$ )
    fix-delims                           ( url$' )
-   " http-proxy" not-alias?  if         ( url$ )
+   /proxy 0=  if
       url-parse null$                   ( filename$ server$ prefix$ )
-      bootnet-debug  if  ." HTTP Server " 2over type cr  then
-   else                                 ( url$ proxy$ )
-      dup  0=  if                       ( url$ proxy$ )
-         2drop url-parse null$          ( filename$ server$ prefix$ )
-         bootnet-debug  if  ." HTTP Proxy server " 2over type cr  then
-      else                              ( url$ proxy$ )
-         " http:"                       ( url$ proxy$ prefix$ )
-      then                              ( url$ proxy$ prefix$ )
+      bootnet-debug  if  ." HTTP: Server is: " 2over type cr  then
+   else                                 ( url$ )
+      proxy /proxy                ( url$ proxy$ )
+      bootnet-debug  if  ." HTTP: Proxy is: " 2dup type cr  then
+      " http:"                          ( url$ proxy$ prefix$ )
    then                                 ( send$ server$ prefix$ )
    2swap  parse-port                    ( send$ prefix$ port# server$ )
 ;
-0 value image-size
--1 value result-code
+
 vocabulary http-tags

: parse-line  ( adr len -- )
@@ -193,7 +225,7 @@

: get-number  ( adr len -- n )  push-decimal $number pop-base throw  ;
 : version-bad?  ( $ -- flag )
-   2dup  " HTTP/1.0" $=  if  2drop false exit  then  ( $ )
+   2dup " HTTP/1.0" $=  if  2drop false exit  then  ( $ )
    2dup " HTTP/1.1" $=  if
       2drop false 
    else
@@ -203,6 +235,11 @@
       true
    then
 ;
+: result-code-supported?  ( # -- supported? )
+   dup to result-code >r	( # )
+   r@ d# 200 =    r@ d# 301 d# 303 between or
+   r@ d# 305 = or r> d# 307 = or
+;
 : dump-response  ( -- )
    begin get-line dup  while  type  cr  repeat
 ;
@@ -212,15 +249,10 @@
    abort" HTTP: Bad version line"	( rem$ )
    skipwhite  scanwhite                 ( rem$ head$ )
    get-number                           ( rem$ # )
-   \ XXX should handle 3xx redirects
-   dup d# 200 <>  if			( rem$ # )
+   dup result-code-supported? not  if	( rem$ # )
       bootnet-debug  if			( rem$ # )
-         dup d# 302 =  if
-            ." HTTP: Response: " .d  type cr	( )
-            dump-response
-         else
-            ." HTTP: Bad response: " .d  type cr	( )
-         then
+         ." HTTP: Bad response: " .d  type cr	( )
+         dump-response
       then				( | rem$ # )
       abort				( )
    else	 3drop  then			( )
@@ -242,6 +274,7 @@
 \ Content-type: text/html
 \ Content-length: 10696
 \ Last-modified: Thu, 11 Feb 1999 01:08:12 GMT
+\ Location: http://www.w3.org/TheProject.html

: content-length  ( $ -- )  \ [<white>] length
    skipwhite scanwhite    ( tail$ head$ )
@@ -249,6 +282,19 @@
    get-number             ( size )
    to image-size
 ;
+: location  ( $ -- )		\ [<white>] url$
+   skipwhite scanwhite		( tail$ head$ )
+   2swap 2drop			( head$ )
+   ascii : left-parse-string 2drop	( head$' )
+   result-code d# 305 =  if
+      set-proxy
+   else
+      dup to /url		( head$ )
+      url swap move		( )
+      null$ set-proxy
+      bootnet-debug  if  ." HTTP: Location: " url /url type cr  then
+   then
+;

previous definitions

@@ -259,7 +305,7 @@
    check-status-line
    begin  get-line  dup  while  parse-header-line  repeat  2drop
 ;
-: mount  ( $url -- error? )
+: (mount)  ( $url -- error? )
    decode-url                           ( send$ prefix$ port# server$ )

2dup set-server                      ( send$ prefix$ port# server$ )
@@ -284,9 +330,18 @@

['] check-header catch
 ;
+: mount  ( url$ -- error? )
+   dup to /url  2dup url swap move
+   begin  (mount) 0=  if  result-code d# 200 <>  else  false  then  while
+      " disconnect" $call-parent
+      url /url
+   repeat
+   result-code d# 200 <>
+;

: open  ( -- )
    my-args dup  if
+      init-proxy
       bootnet-debug  if
          2dup ." HTTP: URL is: " type cr
       then