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

[David L. <wh...@oz...>]

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