Re: [Tclhttpd-users] Q: Using TclHTTPD as a proxy server?

[Jacob L. <jy...@be...>]

David

Thanks!

I was thinking of something simpler. Since there's probably a way to start the
server as a proxy on a certain port, I'd start it on (for example) port 3333 as
a proxy and as usual on port 8015 as a server. That way I'd have two copies of
the server running within one process. AFAIK it's already possible to run
TclHTTPD as a server serving multiple ports (e.g. 8015 and 8080) at the same
time, so this would be a small change.

Comments?

David LeBlanc wrote:

> This might not be exactly a cookbook, but here it is fwiw.
>
> The use of tclhttpd as a proxy server is a recurring question on the list.
>
> Dave LeBlanc
> ****************************************************************
>
> Subject: Proxy Server Using TCL (Please disregard previous post, forgot
> non-binary group! =-)
> From: lu...@pi...
> Date: 1999/05/16
> Newsgroups: comp.lang.tcl
> I am assisting a good friend with this final project, which he needs
> to graduate and I hope someone here can lend a little help if
> possible. Included in this message below is a proxy server written in
> TCL,
> saved in text format. The question he's grappling with is:
>
> Suppose your proxy were ALSO a server.  At what point or points in the
> code (indicate the exact routine and line) would you branch to server
> functionality?  Why?
>
> I'm not familiar with TCL(neither is he) and he needs it by Tuesday in
> order to graduate. =-( Hate to be a bother or anything, but if anyone
> can help, please email me a response to:
>
> lu...@pi...
>
> If anything, I'm hoping this code will assist others with similar
> projects, as sometimes stuff like this is tough to come by. =-)
>
> Thanks...
>
> #!/bin/sh
> # the next line restarts using tclsh \
> exec tclsh "$0" $@
>
> #
> # $Id: http_proxy.tcl,v 4.4 1997/01/30 00:01:19 dl Exp $
> #
> # An Privacy enhanced http proxy,
> # initially based on my geturl2 raw WWW client and my tclhttpd
> # (suitable for anonymous web access)
> #
> # Sample usage:
> #    nohup http_proxy listeningport [nbrhops prox1 ... proxyn] >
> /dev/null &
> # if nbrhops and proxyI are provided,
> # the proxy will generate a random route of nbrhops hops,
> # amongst proxy 1...N   (nbrhops must be >= N)
> #
> # You can see/modify the parameters using your web browser, accessing
> #   http://localhost:listeningport/admin
> # To do this you shall define an APROXYPASS environement variable,
> equal
> # to the md5 digest/checksum of your password, for access to
> # the proxy admin page (use 'md5sum "pass"' proc to get the value)
> # For instance, to use the string 'passwd' as password, use :
> # setenv APROXYPASS 76a2173be6393254e72ffa4d6df1030a
> #
> # NB: POST support and admin parameters modification is not yet
> finished.
> #
> # You need a Binary tcl shell : tcl7.5 or later + tclbin +(and
> optionally tclX)
> # interp to use it
> # ( tcl7.5 needed to listen to tcp port and clock, tclX for
> lassign,etc
> #  and tclbin for real binary IOs, md5 checksum/digest interface,...)
> #
> # To build this shell you need the tclbin distrib
> # http://www.box.eu.org/~dl/tclbin.html and ftp://ftp.box.eu.org/tcl/
> # C source files compressed tar file : tclbin-*.tgz  (currently v1.2)
> #
> # THIS IS A BETA RELEASE - PLEASE DON'T DISSEMINATE
> #
> # (c)1995 by Laurent Demailly - dl...@ww...
> #            http://www.box.eu.org/~dl/
> #
> # Latest version shall always be available from
> # http://www.box.eu.org/~dl/wwwtools.html
> #
> # (please send me feed back, comments, and tell me if you made
> changes,...)
> #
> # ``Artistic'' license see LICENSE - Author: Laurent Demailly
> #
> # This program is free software; you can redistribute it and/or modify
> # it under the terms and CONDITIONS of the included LICENSE
> #
> # If you don't have the LICENSE or need to clarify anything please
> # contact the author
> #
> # This program is distributed in the hope that it will be useful,
> # but WITHOUT ANY WARRANTY; without even the implied warranty of
> # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
> #
> # $Log: http_proxy.tcl,v $
> # Revision 4.4  1997/01/30 00:01:19  dl
> # updated urls and emails. fix in 64ToStr.
> #
> # Revision 4.3  1996/05/08  13:41:04  dl
> # fixed huge bug of unreturned buffer because notreadylock() was not
> unset
> #
> # Revision 4.2  1996/05/02  22:39:03  dl
> # missing -translation binary was causing garbage on binary files
> #
> # Revision 4.1  1996/05/02  21:58:44  dl
> # Tcl(7.5) + tclbin only version (and optional tclX)
> # no more tcldp.
> # no 100% finished yet [the write blocking must be reimplemented
> nicely]
> #
> # Revision 3.8  1996/04/22  18:54:47  dl
> # added a lock for client waiting / close while waiting case
> # typo/bugfix peer was not declared global in main handler
> #
> # Revision 3.7  1996/04/09  15:52:04  dl
> # Don't send more bytes than "Content-Length" in request, even if
> client does
> #
> # Revision 3.6  1996/04/09  15:32:01  dl
> # added `small' POST requets support ! (which implied a binary read of
> # headers/client too...)
> # optional passing of Authorization* headers
> #
> # [old logs deleted for space sake]
>
> # If you didn't "make install"
> # copy libdlbin.sl to /usr/local/lib/tcl7.5
> # and run
> # echo 'pkg_mkIndex /usr/local/lib/tcl7.5 *[info sharedlibextension]'|
> tclsh7.5
> # or
> #lappend auto_path .
> # to test it in current directory
>
> package require Bin;
> package require Mdfive;
>
> if [catch {package require Tclx} res] {
>   puts "Running without tclX ($res) (using compat in tcl lib, a bit
> slower)";
> # Some minimal TclX replacements...
> proc getclock {} {clock seconds}
> proc lempty {lst} {regexp "\[ \t\n\]" $lst}
>
> proc fmtclock {clockval {format {}} {zone {}}} {
>     lappend cmd clock format $clockval
>     if ![lempty $format] {
>         lappend cmd -format $format
>     }
>     if ![lempty $zone] {
>         lappend cmd -gmt 1
>     }
>     return [eval $cmd]
> }
> # simple one (no step/no continue...)
> proc loop {var start end body} {
>   upvar $var v;
>   for {set v $start} {$v<$end} {incr v} {
>     uplevel $body;
>   }
> }
> proc lassign {list args} {
>   set i 0;
>   foreach vname $args {
>     uplevel [list set $vname [lindex $list $i]];
>     incr i;
>   }
>   lrange $list $i end
> }
> proc clength {str} {string length $str}
> proc cequal {s1 s2} {expr [string compare $s1 $s2]==0}
> # simple, we don't do "end"
> proc crange {str first last} {string range $str [expr $first] [expr
> $last]}
> # tcl-usage' faq random :
> proc random {args} {
>   global RNG_seed;
>
>   set max 259200;
>   set argcnt [llength $args];
>   if { $argcnt < 1 || $argcnt > 2 } {
>     error "wrong # args: random limit | seed ?seedval?"
>   }
>   if ![string compare [lindex $args 0] seed] {
>     if { $argcnt == 2 } {
>       set RNG_seed [lindex $args 1]
>     } else {
>       set RNG_seed [clock clicks] ; # poor...
>     }
>     return;
>   }
>   if ![info exists RNG_seed] {
>     set RNG_seed [clock clicks] ; # poor...
>   }
>   set RNG_seed [expr ($RNG_seed*7141+54773) % $max]
>   return [expr int(double($RNG_seed)*[lindex $args 0]/$max)]
> }
> proc lvarpop {var} {
>   upvar $var v;
>   set r [lindex $v 0];
>   set v [lrange $v 1 end];
>   return $r;
> }
> }
>
> #
> # ---------- start of CONFIGURABLE section ----------
>
> # max simultaneous proxy connections allowed
> set maxconn 4
> # absolute maximum (each proxy requires 2 connections)
> set absmaxconn [expr 2*$maxconn];
> # timeout in seconds for getting a query  (in milli-seconds)
> set qtimeout 20000;
> # timeout for the whole connect  (600000 = 10 mins)
> set stimeout 120000 ; # two minutes is enough (we want to be fast)
> # buffer size for one connection
> set bufsz 32768 ;#16384; #8192
>
> # set denied(aaa.bbb.ccc.ddd) 1;
>
> # proc that is called for each connecting IP and shall return 0 for ok
> # and 1 for denied.
> proc access_forbid {host} {
>   global denied;
> # like this, unless host is found in the above 'denied' array, access
> granted
> # but this proc can be complexified at will to support any kind of
> access ctrl
>   info exists denied($host)
> }
>
> # ---------- end of configurable section ----------
>
> # determine this server host and domain name :
>
> # Note: on some OS/configs hostname is directly the fqhn
> # (for me, not)
> set hostname [lindex [split [exec hostname] .] 0];
> # the running host full qualified name (host.domain name)
> set fqhn [exec nslookup $hostname]
> regexp "Name: +(\[^\n\]+)\n" $fqhn all fqhn;
> # domain name alone
> regexp {^([^\.]+)\.(.+)$} $fqhn all hn domain;
> # (btw hn should be == hostname)
>
> # record starting time
> set dateup [fmtclock [getclock] "%d %h %Y %H:%M %Z" GMT];
>
> #
> # Buffer setup
> #
>
> # total buffer size
> set bigbufsz [expr $bufsz*$maxconn];
>
> bin_new bigbuf buffer $bigbufsz;
> set freebuflst {};
>
> loop i 0 $maxconn {
>   # split the big buf in smaller shunks
>   bin_new buf${i} buffer $bufsz bigbuf $i*$bufsz;
>   bin_new buf${i}in  buffer $bufsz buf${i};
>   bin_new buf${i}out buffer 0      buf${i};
>   lappend freebuflst $i;
> }
>
> proc getfreebuf {} {
>   global freebuflst;
>   set res [lvarpop freebuflst]
>   if {[cequal $res ""]} {error "no more bufs!"}
>   return $res
> }
>
> proc givebackbuf {i} {
>   global freebuflst;
>   lappend freebuflst $i;
>   global buf${i}in buf${i}out;
>   bin_move -absolute buf${i}out 0;
>   bin_move -absolute buf${i}in  0;
>   global bufsz;
>   bin_resize buf${i}in $bufsz;
> }
>
> # by default, only one routing
> set autoroute {}
> set nbrhops 0;
> # by default, post is not allowed
> #set allowpost 0;
> set allowpost 1;
>
> # allow authorization* headers ?
> set allowauth 1;
>
> # rcs kewords extraction
> regexp {[.0-9]+} {$Revision: 4.4 $} version
>
> # Proxy List keyword in http header:
> set plistkeyw "ProxyControl";
> # Protocol Version
> set plistvers 1
>
> # debug ?
> set debug 2
> if {[info exists env(DEBUG)]} {
>   set debug $env(DEBUG);
>   if {[catch {expr $debug>0}]} {set debug 0}
> }
>
> #
> # proxy transfer handler, called when there is something to read
> # on the socket server socket (copy it to the client):
> #
> proc trans_handler {cliconn mode servconn {recurs 0}} {
>   global trkbytes debug;
> #  puts "called trans_handler $cliconn $servconn $recurs";
>   global bufid bufsz;
>   set id $bufid($servconn);
>   upvar buf${id}in  bufin ;
>   upvar buf${id}out bufout ;
>
>   if {[catch {bin_sizeof bufin} sz1]} {
>     puts "hmmm error '$sz1' for id=$id, on
> $cliconn,$servconn,$recurs";
>     do_close $cliconn "error bufin!";
>   }
>   if {$sz1!=0} {
>     if {[catch {set n [bin_read $servconn bufin]} res]} {
>       set n 0;
> if {$debug>=1} {
>       puts "th $cliconn $servconn : got read error : $res";
> }
>     }
> if {$debug>=3} {
>     puts "th $cliconn $servconn : read $n/$sz1 bytes";
> }
>   } else {
>     set n 0;
> if {$debug>=3} {
>     puts "th $cliconn $servconn : read buffer full, no read";
> }
>   }
>   if {$n==0} {
>     if {[bin_sizeof bufout]==0} {
>       do_close $cliconn "transmit done (now $trkbytes kb)";
>       return;
>     }
>   } else {
>     bin_resize bufin $sz1-$n;
>     set szi [bin_move bufin $n 1];
> # we got a bug in the resize below... (should be fixed by the
> notreadylock..)
> #puts "trh c=$cliconn m=$mode s=$servconn r=$recurs
> n=$n,sz1=$sz1,szi=$szi";
>     if {[catch {bin_resize bufout $szi-[bin_move bufout 0]} msg]} {
>       puts "error resize bufout: [bin_info bufout]";
>       tkerror $msg;
>     }
>   }
>
>   if {$recurs} {return $n}
>
> #  if {[lempty [lindex [select {} $cliconn {} .2] 1]]}
> #  global writable
> #  set writable($cliconn) 0
> #  fileevent $cliconn w "set writable($cliconn) 1";
> #  puts "before vwait writable($cliconn)";
> #  fileevent $servconn r {};
> #  vwait writable($cliconn);
> #  fileevent $servconn r "trans_handler $cliconn r $servconn";
> #  puts "after  vwait writable($cliconn)";
>
>   if {0} { # with tcl7.5 we can always write... (!)
>     # not ready to write...
> if {$debug>=3} {
>     puts "th $cliconn $servconn : client not ready 1 for writing";
> }
>     fileevent $servconn r {};
>     global notreadylock;
>     set notreadylock($servconn) 1;
>     update
>     if {!$notreadylock($servconn)} {
>       # socket have been closed in update, finish do_close' job
>       givebackbuf $bufid($servconn);
>       unset bufid($servconn);
>       unset notreadylock($servconn);
>       return ;
>     }
>     while {[lempty [lindex [select {} $cliconn {} .2] 1]]} {
> if {$debug>=2} {
>       puts "th $cliconn $servconn : client not ready n for writing";
> }
>       update;
>       if {!$notreadylock($servconn)} {
>         # socket have been closed in update, finish do_close' job
>         givebackbuf $bufid($servconn);
>         unset bufid($servconn);
>         unset notreadylock($servconn);
>         return ;
>       }
>       if {[uplevel #0 trans_handler $cliconn $mode $servconn 1]==0} {
>         loop i 0 4 {
>           after 250
>           update
>           if {!$notreadylock($servconn)} {
>             # socket have been closed in update, finish do_close' job
>             givebackbuf $bufid($servconn);
>             unset bufid($servconn);
>             unset notreadylock($servconn);
>             return ;
>           }
>         }
>       }
>     }
>     unset notreadylock($servconn);
>     fileevent $servconn r "trans_handler $cliconn r $servconn";
>   }
>
>   set sz2 [bin_sizeof bufout];
>   if {[catch {set p [bin_write - $cliconn bufout]} res]} {
>     set p 0;
> if {$debug>=1} {
>     puts "th $cliconn $servconn : got a write error : $res";
> }
>   }
> if {$debug>=3} {
>   puts "th $cliconn $servconn : wrote $p/$sz2";
> }
>   bin_resize bufout $sz2-$p;
>   if {$p==$sz2} {
> # everything was read
> #    puts "reset";
>     bin_move -absolute bufout 0;
>     bin_move -absolute bufin  0;
>     bin_resize bufin $bufsz;
>   } else {
>     bin_move bufout $p 1;
>   }
> #  catch {flush $cliconn}
>   set trkbytes [expr $trkbytes+$n/1024.];
> #  puts "th $cliconn $servconn : transmitted $n bytes -> $trkbytes";
> }
>
> #
> # usage / startup error
> #
> proc usage {msg} {
> puts stderr "Error $msg";
> puts stderr "Usage: [info script] port \[nbrhops proxy1 ...proxyN\]";
> exit 1;
> }
>
> if {$argc==0} {usage "no port given!"};
>
> lassign $argv port;
> if {$argc==2} {usage "nbrhops given but no proxies!"};
> if {$argc>2} {
>   set nbrhops [lindex $argv 1];
>   set autoroute [lrange $argv 2 $argc];
>   set lg [llength $autoroute];
>   if {[catch {expr $nbrhops>$lg} res]} {usage "nbrhops is not a
> number!"};
>   if {$res} {usage "nbrhops > number of proxies given!"};
> };
>
> # listen on port
> set srv [socket -server newconn $port]
> # init counters and stat:
> set nbrconn 0;
> set count 0;
> set pcount 0;
> set trkbytes 0.0;
>
> # connect handler:
> puts stderr "listening on host $fqhn ($hostname,$domain) on port
> $port";
> puts stderr "nbrhops=$nbrhops, autoroute=($autoroute)";
>
> # accept connects:
> proc newconn {socket host port} {
>   global count absmaxconn nbrconn qtimeout time queue ql debug;
>   set ts [getclock];
> if {$debug>=1} {
>   puts "C $ts ($nbrconn,$count) $host -> $socket";
> }
>   incr count;
>   if {[access_forbid $host]} {
> if {$debug>=0} {
>     puts "denied $host";
> }
>     catch {close $socket};
>     return
>   }
>   incr nbrconn;
> #  dp_socketOption $socket sendBuffer 16384;
>   fconfigure $socket -blocking no -translation binary;
> #  dp_socketOption $socket keepalive yes;
>   if {$nbrconn>$absmaxconn} {
>      toobusy $socket "Too many connections ($nbrconn), reload in few
> moments"
>      return;
>   };
>   set time($socket) $ts;
>   set queue($socket) {};
>   set ql($socket) 0;
>   fileevent $socket r "handler $host r $socket";
>   after $qtimeout "qtimeout $socket $ts"
> }
>
> proc qtimeout {file ts} {
>   global time;
>   #puts "called timeout $file $ts";
>   if {[info exists time($file)]} {
>     #puts "times($file)=$times($file)";
>     if {$time($file)==$ts} {
>       serror $file "Received no valid query" 408 "Request Timeout";
>     }
>   }
> }
>
> proc stimeout {file ts} {
>   global time;
>   #puts "called timeout $file $ts";
>   if {[info exists time($file)]} {
>     #puts "times($file)=$times($file)";
>     if {$time($file)==$ts} {
>       do_close $file "session too long";
>     }
>   }
> }
>
> # read buffer
> bin_new buffer buffer 16384;
> bin_new bufptr buffer 0 buffer;
> bin_new bufrst buffer 0 buffer;
>
> # Main connection handler
> # determines what is requested and what to call for answer
> #
> proc handler {host mode file} {
>   global peer time queue ql plistkeyw plistvers debug \
>      fqhn hostname domain port nbrhops autoroute allowpost allowauth;
>   set what {};
>   global buffer bufptr bufrst;
>   if {[catch {bin_read $file buffer} lg]} {
>     do_close $file "read error '$lg'";
>     return;
>   }
> #  puts "called handler $file : read '$what'";
>   if {$lg==0} {do_close $file "eof"; return}
>   if {[info exists peer($file)]} {return}; #ignore what client says
> after conn
>   bin_resize bufptr $lg;
>   set what $bufptr(_str_);
>   regsub -all {\\.} $what {\\} what; # so [clength $what] is r
>   # (side effect: if there are '\0' in headers (which is illegal),
>   # they'll appear as '\')
>   append queue($file) $what;
>   # header is fully here ? (if not we just wait)
>   if {![regexp -indices "\r?\n\r?\n" $queue($file) idx]} {
>     if {($ql($file)+$lg)>1024} {
>       serror $file "" 400 "Query too long"
>     } else {
>       incr ql($file) $lg;
>     }
>     return;
>   }
>   # cool, we found the header separation
>   lassign $idx p1 p2;
>   set rest [expr $lg-($p2+1-$ql($file))];
>   bin_resize bufrst $rest;
>   if {$rest!=0} {
>     bin_move -absolute bufrst $lg-$rest 1;
> if {$debug>=4} {
>   puts "remaining $rest bytes! ($bufrst(_str_))";
> }
>   }
>   set what [crange $queue($file) 0 $p1-1];
>   regsub -all "\r" $what {} what;
>   if {![regexp \
> "^(\[^ \n\]+) (\[^ \n\]+) HTTP/1.0(\n(.+\n)?($plistkeyw: V(\[0-9\]+)
> ?(\[^\n\]*))\n)?"\
>    $what gall method url r1 r2 apline apvers aplist]} {
>     # wrong command... problem
>     serror $file \
>            "Format unrecognized:\n<pre>\n[txt2html $what]</pre>" \
>            400 "Bad Request";
>     return;
>   }
>   if {![regexp {^(GET|HEAD|POST)$} $method]} {
>     # not implemented method
>     serror $file \
>       "Sorry, the method <strong>$method</strong> is not
> implemented.\n\
>       <p>Your query was\n<pre>\n[txt2html $what]</pre>" \
>       501 "Not Implemented ($method)";
>     return;
>   }
>   # if a local url is requested, skip proxying it :
>   if {[regsub -nocase
> "^http://($fqhn|$hostname|localhost(\.$domain)?|127\.0\.0\.1):$port/"
> $url / url]} {
> if {$debug>=3} {
>     puts "url found to be local ($url)"
> }
>   }
>   # Do we want full thing or headers only?
>   set getflag [expr ![cequal $method "HEAD"]];
>   set postflag [cequal $method "POST"];
>   set moreheaders {};
>   set contentLG 0;
>   if {$postflag} {
>     # get and check content-length
>     set contentLG 0;
>     regexp -nocase {Content-length: *([0-9]+)} $what all contentLG;
>     if {$contentLG>$rest} {
>       serror $file "I can't handle this post request because\
> \nYou have to send $contentLG bytes and I've read only $rest bytes..."
> \
>       500 "Can't handle this Post $rest/$contentLG";
>       return;
>     }
>     if {$contentLG>0} {bin_resize bufrst $contentLG}
>     # extract/save all Content-* headers
>     set all $what;
>     while {[regexp -nocase "\n(Content-\[^\n\]+)(.*)$" $all a ct all]}
> {lappend moreheaders $ct}
>   }
>   if {$allowauth} {
>     set all $what;
>     while {[regexp -nocase "\n(Authorization\[^\n\]+)(.*)$" $all a ct
> all]} {lappend moreheaders $ct}
>   }
>   if {$debug>5} {puts "content=($moreheaders), contentLG=$contentLG"}
>   switch -regexp -- $url {
>       {^/admin}   {
>         if {[regexp -nocase "\nAuthorization: +Basic +(\[^\n\]+)" \
>                     $what all auth]} {
>           set user "";
>           set pass "";
>           regexp {^([^:]+):(.+)$} [64ToStr $auth] all user pass;
>           if {[admincheck $host $user $pass]} {
>             serror $file "Bad host/user/passwd" 401 \
>               "Unauthorized" "WWW-Authenticate: Basic
> realm=\"admin\"\n";
>           } else {
>             admin $file $getflag $host $user $pass;
>           }
>         } else {
>           serror $file "You need an authorisation capable browser to
> access" \
>             401 "Unauthorized" "WWW-Authenticate: Basic
> realm=\"admin\"\n";
>         }
>       }
>       {^/source} {sendsource     $file $getflag}
>       {^/}       {sendserverinfo $file $getflag [txt2html
> $queue($file)]}
>       default {
>         if {$postflag && !$allowpost} {
>           serror $file "POST is disabled.\n\
>           <p>Your query was\n<pre>\n[txt2html $queue($file)]</pre>" \
>           403 "Forbidden";
>           return;
>         }
>         # real proxy job:
>         # parse the url :
>         if {![regexp {^http://([^/:]+)(:([0-9]+))?(/[^#]*)?(#.*)?$}
> $url \
>                      all dhost p dport what key]} {
>             # for instance port must be numerical
> if {$debug>=2} {
>         puts "invalid url='$url' ($queue($file))";
> }
>             serror $file "<pre>$url</pre>" 400 "Invalid Proxy URL";
>             return;
>           }
>         if {[cequal $dport ""]} {set dport 80}
>         if {[cequal $what ""]} {set what "/"}
> # port checking #1/2 :
>         if {$dport<1024 && $dport!=80} {serror $file "Illegal dest.
> port $dport" 403 "Forbidden"; return}
>         set apflag [expr [cequal $apline ""]==0];
> if {$debug>=1} {
>         puts "$file -> proxying $method http://$dhost:$dport$what
> ($apline)";
> }
>         if {$apflag} {
>           if {([catch {expr $apvers!=$plistvers} res] || $res)} {
>            serror $file "<pre>$apline</pre>" 500 "Invalid Proxy Ctrl
> Version";
>            return;
>           }
>           if {[catch {llength $aplist} lg]} {
>            serror $file "<pre>$aplist</pre>" 400 "Invalid Proxy List";
>            return;
>           }
>         } else {
>           if {$nbrhops!=0} {
>             # generate a random proxy route, choosen in autoroute
>             set aplist [random_path $nbrhops $autoroute [llength
> $autoroute]];
>             set lg [llength $aplist];
> if {$debug>=1} {
>             puts "generated random path ($aplist)";
> }
>           } else {set lg 0}
>         }
>         if {$lg>=1} {
>           set thisproxy [lindex $aplist 0];
>           set restproxy [lrange $aplist 1 $lg];
>           if {![regexp {^(.+):([0-9]+)$} $thisproxy all phost pport]}
> {
>             serror $file "<pre>$thisproxy</pre>" 400 "Invalid Next
> Proxy Entry";
>             return;
>           }
>           lappend moreheaders "$plistkeyw: V$plistvers $restproxy";
> # port checking #2/2 :
>           if {$pport<1024 && $pport!=80} {serror $file "Illegal proxy
> port $pport" 403 "Forbidden"; return}
>           do_query $file $method $phost $pport \
>              "http://$dhost:$dport$what" [join $moreheaders \r\n]
> $contentLG;
>         } else {
>           lappend moreheaders $apline;
>           do_query $file $method $dhost $dport $what [join
> $moreheaders \r\n] $contentLG;
>         }
>       }
>     }
> }
>
> proc random_path {n list lg} {
>  set idx [random $lg]
>  if {$n>1} {
>    incr n -1;
>    incr lg -1;
>    return "[lindex $list $idx] [random_path $n [lreplace $list $idx
> $idx] $lg]"
>  } else {
>    return "[lindex $list $idx]"
>  }
> }
>
> proc txt2html {str} {
> regsub -all "&" $str {\&amp;} str;
> regsub -all "<" $str {\&lt;} str;
> regsub -all ">" $str {\&gt;} str;
> regsub -all \" $str {\&quot;} str;
> return $str;
> }
>
> proc toobusy {file msg} {
>   serror $file "$msg\n<p>Try to <b>reload</b> in a moment" 503
> "Service Overloaded" \
>              "Retry-After: 15\n";
> }
>
> proc serror {file msg {id 500} {title "Error"} {more ""}} {
>   global version fqhn port;
>   catch {
>     puts $file "HTTP/1.0 $id $title
> Server: tclProxy/dl$version
> Content-Type: text/html
> $more
> <HEAD><TITLE>$title</TITLE>
> <link rev=\"made\" href=\"mailto:ld...@ma...\">
> </HEAD>
> <BODY>
> <H1>$title</H1>
> $msg
> <HR>
> <ADDRESS>
> <A HREF=\"http://$fqhn:$port\">
> Anonymous proxy httpd</a> v$version server in tcl, by
> <A HREF=\"http://www.box.eu.org/~dl/\">dl</A>
> </ADDRESS>
> </BODY>"
>   }
>   do_close $file "error ($id $title)";
> }
>
> proc htmlblah {file getflag title msg} {
>   global version;
>    set sendstr "<HEAD><TITLE>$title</TITLE>
> <link rev=\"made\" href=\"mailto:ld...@ma...\">
> </HEAD>
> <BODY>
> <H1>$title</H1>
> $msg
> <HR>
> <ADDRESS>
> <A HREF=\"http://www.box.eu.org/~dl/wwwtools.html\">
> Anonymous proxy httpd</a> v$version server in tcl,
> <A HREF=\"http://www.box.eu.org/~dl/disclaimer.html\">&copy;</A>
>  by
> <A HREF=\"http://www.box.eu.org/~dl/\">dl</A>
> </ADDRESS>
> </BODY>
> "
>   set sl  [clength $sendstr];
>   set chk [md5sum  $sendstr];
>   catch {
>     puts $file "HTTP/1.0 200 Document follows
> Server: tclProxy/dl$version
> Content-Type: text/html
> Content-Length: $sl
> Content-Digest: MD5=$chk
> "
>   flush $file;
>   if $getflag {puts -nonewline $file $sendstr}
>   }
>   do_close $file "htmlblah $getflag ($title)";
> }
>
> proc sendserverinfo {file getflag what} {
>   global nbrconn absmaxconn count pcount dateup trkbytes fqhn port
> freebuflst;
>         htmlblah $file $getflag "Anonymous Proxy HTTP Server" "
> Welcome on this experimental WWW proxy server, feel free to use it
> (but not
> abuse it, <b>please</b>), source is
> <a href=\"/source\">here</a> and latest version and informations are
> on
> <a href=\"http://www.box.eu.org/~dl/wwwtools.html\">
> http://www.box.eu.org/~dl/wwwtools.html</a>.<p>
> Use <tt>setenv http_proxy http://$fqhn:$port/</tt> to use it, or
> better, run
> a local copy and join the privacy http proxy network.
> <p>
> Access restricted <a href=\"http://localhost:$port/admin\">proxy
> admin</a>.
> <p>
> Look at the amount of information <em>your</em> browser is sending
> (and this
> proxy is throwing away) :<br>
> See for instance the <a href=\"refered\">Referer:</a> that might
> contain
> very personal informations (back links).
> (Not all browsers put a Referer field, though)
> <pre>
> $what</pre>
> <p>
> Currently: $nbrconn/$absmaxconn open connections,<br>
> Free buffers: $freebuflst<br>
> Served a total of $count requests since $dateup<br>
> Proxy requests: $pcount, transmitted [format %.1f $trkbytes] kbytes"
> }
> #
> # Closing proc
> #
> proc do_close {file msg} {
>   global nbrconn time queue ql peer bufid debug;
> if {$debug>=1} {
>   puts "closing $file ($msg)"; flush stdout;
> }
>   catch {fileevent $file r {} }
>   catch {unset time($file)}
>   catch {unset queue($file)}
>   catch {unset ql($file)}
>   global notreadylock;
>   if {[info exists bufid($file)]} {
>     if {[info exists notreadylock($file)]} {
>       set notreadylock($file) 0; # raise flag so it can given back
> later...
>     } else {
>       givebackbuf $bufid($file);
>       unset bufid($file);
>     }
>   }
>   if {[info exists peer($file)]} {
>     set mypeer $peer($file);
>     unset peer($file);
>     if {[info exists time($mypeer)]} {do_close $mypeer "peer $msg"}
>   }
> #  catch {flush $file}
>   catch {close $file}
>   incr nbrconn -1;
> }
>
> proc do_query {file method host port what apline contentLG} {
> global peer bufid time stimeout version count pcount conn nbrconn
> debug;
> # connect to the host
> if {[catch {set socket [socket $host $port]} msg]} {
>   puts stderr "connect on $host port $port : $msg";
>   serror $file "Connect error on $host port $port : $msg" 404 "Not
> found";
>   return;
> }
> # dp_filehandler $file; #ignore what client migh say now
> # (in fact not, lets detect close)
>
> fconfigure $socket -blocking no -translation binary;
> #dp_socketOption $socket keepalive yes;
> set ts [getclock]
> if {$debug>=1} {
> puts "S $ts ($nbrconn,$count) $host:$port -> $socket";
> }
> set time($socket) $ts;
> set time($file) -$ts;
> set peer($file) $socket;
> set peer($socket) $file;
> incr count;
> incr pcount;
> incr nbrconn;
> if {[catch getfreebuf res]} {
>      toobusy $file "Too many connections ($nbrconn) ($res), reload in
> few moments"
>      return;
> }
> set bufid($socket) $res;
> after $stimeout "stimeout $socket $ts"
> #puts "Sending $method $what to $host:$port"
> # send the httpd query :
> if {![cequal $apline ""]} {set more "\n$apline\r"} else {set more ""}
> set what "$method $what HTTP/1.0\r$more
> User-Agent: tclproxy/dl$version
> (http://www.box.eu.org/~dl/wwwtools.html)\r
> Accept: */*\r
> \r\n"
> set lg [string length $what];
> bin_new query buffer $lg;
> regsub -all {\\} $what {\\\\} what;
> set query(_str_) $what;
> set wrote [bin_write $socket query];
> if {$wrote<$lg} {puts "probable error on $socket : $wrote<$lg"}
> if {$contentLG>0} {
>   global bufrst;
>   set contentWR [bin_write $socket bufrst];
>   if {$contentWR<$contentLG} {puts "probable post error on $socket :
> $contentWR<$contentLG"} elseif {$debug>=3} {
>   puts "sent request&post data ($wrote+$contentWR bytes) on $socket"
>   }
> } elseif {$debug>=3} {
>   puts "sent request ($wrote bytes) on $socket"
> }
> if [catch {flush $socket} msg] {puts "flushing error $msg"}
> fileevent $socket r "trans_handler $file r $socket";
> }
>
> # *** WWW utilities extracted from my other stuff :
>
> # *** base64.tcl
>
> # authorisation mecanism
> # Base64 <-> String  Translation, in TclX,
> # 9/1995 by Laurent Demailly - ld...@ma... -
> http://www.box.eu.org/~dl/
> # Free Software - No warranty
>
> set _pad "="
> set _base64 \
>   "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
>
> # encode a tcl string using base64 mime like coding
> proc StrTo64 {bin} {
>   global _pad _base64;
>   set lg [clength $bin]
>   set res {};
>   loop i 2 $lg 3 {
>     scan [crange $bin $i-2 $i] %c%c%c a b c;
>     append res [cindex $_base64 [expr $a>>2]];
>     append res [cindex $_base64 [expr (($a&03)<<4) | ($b>>4)]];
>     append res [cindex $_base64 [expr (($b&017)<<2)| ($c>>6)]];
>     append res [cindex $_base64 [expr  ($c&077)]];
>   }
>   if {$lg%3} {
>     set b 0;
>     scan [crange $bin $i-2 $i] %c%c a b;
>     append res [cindex $_base64 [expr $a>>2]];
>     append res [cindex $_base64 [expr (($a&03)<<4) | ($b>>4)]];
>     if {$lg%3==1} {
>       append res $_pad$_pad;
>     } else {
>       append res [cindex $_base64 [expr ($b&017)<<2]];
>       append res $_pad;
>     }
>   }
>   return $res;
> }
>
> # restore string that was base64 encoded. If there are encoded '\0'
> they
> # will simply be skipped
> proc 64ToStr {coded} {
>   global _base64 _pad;
>   set lg [clength $coded];
>   if {$lg%4} {error "Invalid length $lg for a base 64 encoded string"}
>   set res {};
>   loop i 0 $lg 4 {
>     loop j 0 4 {
>       set c [cindex $coded $i+$j];
>       set n$j [string first $c $_base64];
> # comment out /remove the sanity tests below for better performance:
>       if \$n$j==-1 {
>         if {[cequal $c $_pad]} {
>           if {$i+$j<$lg-2} {
>             error "illegal padding char early in base64 coded string"
>           }
>         } else {
>           error "illegal char '$c' for a base64 coded string"
>         }
>       }
>     }
>     append res [format %c [expr ($n0<<2)+($n1>>4)]];
>     if $n2==-1 {
>       if $n3!=-1 {
>         error "last char is not pad while the one before is ('$_pad')"
>       }
>     } else {
>       append res [format %c [expr (($n1 & 0xf)<<4)+($n2>>2)]]
>       if $n3!=-1 {append res [format %c [expr (($n2 & 3)<<6)+$n3]]}
>     }
>   }
>   return $res;
> }
>
> # *** uncgi.tcl
>
> # from UnCgi Translation hack, in Tcl, v1.5 5/1995 by
> dl...@ww...
> proc uncgi {buf} {
> regsub -all {\\(.)} $buf {\1} buf ;
> regsub -all {\\} $buf {\\\\} buf ;
> regsub -all { }  $buf {\ } buf ;
> regsub -all {\+} $buf {\ } buf ;
> regsub -all {\$} $buf {\$} buf ;
> regsub -all \n   $buf {\n} buf ;
> regsub -all {;}  $buf {\;} buf ;
> regsub -all {\[} $buf {\[} buf ;
> regsub -all \" $buf \\\" buf ;
> regsub  ^\{ $buf \\\{ buf ;
> regsub -all -nocase {%([a-fA-F0-9][a-fA-F0-9])} $buf {[format %c
> 0x\1]} buf
> eval return \"$buf\"
> }
>
> # *** parse cgi message
>
> # returns in the 'cgi' array all the parameters sent to the script
> # through 'message' (each array cell is a list (ie if only one value
> # is expected through 'test' variable, use [lindex $cgi(test) 0] to
> get it)).
> proc parse_cgi_message {message} {
> global cgi;
> set cgi() "";
> foreach pair [split $message &] {
>   set plst [split $pair =];
>   set name [uncgi [lindex $plst 0]];
>   set val  [uncgi [lindex $plst 1]];
>   lappend cgi($name) $val;
> }
> }
>
> # *** end of included utilities
>
> # Admin Check access
> proc admincheck {host user pass} {
>   global debug;
> if {$debug>=2} {
>   puts "A $user@$host"
> }
>   # because passwd are sent almost clear, allow only localhost
> connects:
>   if {![cequal $host 127.0.0.1]} {return 1}
>   # (note that it is only because the proxy strips headers that it
> can't
>   #  be used against itself to 'appear' from localhost)
>
>   # using running name as user  (this is not a secret !)
>   global env;
>   if {![cequal $user $env(LOGNAME)]} {return 1}
>   # passcheck, using md5 digest
>   if {![info exists env(APROXYPASS)]} {
>     puts "APROXYPASS env var not defined!";
>     return 1;
>   }
>   if {![cequal [md5sum $pass] $env(APROXYPASS)]} {return 1}
>   return 0; # access granted
> }
>
> proc md5sum {what} {
>   bin_new d digest 16;
>   bin_new w object [clength $what];
>   regsub -all {\\} $what {\\\\} what;
>   set w(_str_) $what;
>   md5 d w;
>   return $d(_hex_);
> }
>
> proc admin {file getflag host user pass} {
>   global nbrconn absmaxconn count pcount dateup trkbytes fqhn port
> freebuflst \
>          nbrhops autoroute allowpost;
>   htmlblah $file $getflag "Proxy HTTP Server Admin" \
>         "Welcome $user, from $host on the WWW proxy server
> administration page
> <p>
> <form action=\"/debug\" method=\"Post\">
> Number of hops (must be &lt;= number of proxies in the route list):
>  <input name=\"nbrhops\" value=\"$nbrhops\" size=3><p>
> Proxy route list (each proxy as host:port):<br>
> <input name=\"autoroute\" value=\"$autoroute\"
> size=[expr [clength $autoroute]+15]><p>
> Allow Post:
> <input type=\"checkbox\" name=\"post\" [if $allowpost {set res
> CHECKED}]><p>
> <input type=\"submit\" value=\"Change! (Not yet working)\">
> </form>
> <p>
> Currently: $nbrconn/$absmaxconn open connections,<br>
> Free buffers: $freebuflst<br>
> Served a total of $count requests since $dateup<br>
> Proxy requests: $pcount, transmitted [format %.1f $trkbytes] kbytes
> <p>
> <a href=\"/\">Back to server root</a>
> "
> }
>
> # store the source
> set sname [info script]
> set fic [open $sname]
> set source  [read $fic]
> set slength [clength $source]
> set schk    [md5sum  $source]
> close $fic;
>
> proc sendsource {file getflag} {
>   global source slength schk version;
> # we have to increase the buffer so we can write the whole source in
> # a single puts
>   fconfigure $file -buffersize 32768;
>   catch {
>     set title "Document follows"
>     puts $file "HTTP/1.0 200 Document follows
> Server: tclProxy/dl$version (infos on
> http://www.box.eu.org/~dl/wwwtools.html)
> Content-Type: text/plain
> Content-Length: $slength
> Content-Digest: MD5=$schk
> "
>    flush $file;
>    if $getflag {puts -nonewline $file $source}
>   }
>   do_close $file "source sent";
> }
>
> set version "${version}d${debug}"
>
> # background error handler (exit with trace output)
> proc tkerror {mess} {
> global errorInfo;
> puts stderr "BACKGROUND ERROR : $mess";
> puts stderr "ERRORINFO: $errorInfo";
> exit 0;
> }
>
> set errorInfo {};
>
> puts "sourced ok"
> vwait forever;
> #EOF
>
> (end of original message)
> ----------------------------------------------------------------------------
> --
>
> You can view this message and the related discussion by following this link:
> http://www.deja.com/%5bST_rn%3dap%5d/dnquery.xp?search=thread&svcclass=dnser
> ver&recnum=%3c3...@ne...%3e%231/8
> We hope to see you soon at Deja.com.
> Before you buy.
> http://www.deja.com/%5bST_rn%3dap%5d/
>
> -----Original Message-----
> From: tcl...@li...
> [mailto:tcl...@li...]On Behalf Of Jacob
> Levy
> Sent: Saturday, December 02, 2000 10:57 AM
> To: tcl...@li...
> Subject: [Tclhttpd-users] Q: Using TclHTTPD as a proxy server?
>
> Two questions:
>
> * Is it possible to use TclHTTPD as a proxy server? If so, how? A
> cookbook explanation would be nice. Thanks!
> * Is it possible to use TclHTTPD both as a proxy server and as a local
> web server at the same time? Again, a cookbook example piece of code
> would be appreciated.
>
> Thanks! --JYL
>
> _______________________________________________
> TclHttpd-users mailing list
> Tcl...@li...
> http://lists.sourceforge.net/mailman/listinfo/tclhttpd-users
>
> _______________________________________________
> TclHttpd-users mailing list
> Tcl...@li...
> http://lists.sourceforge.net/mailman/listinfo/tclhttpd-users