Here is also attached a complete (?) proxy written in Tcl that I got off deja-gnu at one point. It seems to be a product of the notorious M. Laurent Demailly who can be found lurking from time to time on c.l.t ;-) Dave LeBlanc -----Original Message----- From: [EMAIL PROTECTED] [mailto:[EMAIL PROTECTED]] Sent: Wednesday, July 26, 2000 11:25 PM To: [EMAIL PROTECTED] Subject: How to build a filtering firewall module using TCL? Hello everyone, I am stuck with a project to develop a filtering firewall module in LINUX environment in less than two months. I am very new to TCL and I am struggling to learn up the basics and at the same time I have to develop the module. I would really appreciate very much if anyone could at least guide me into arriving at the solutions. Thank you very much. Kevin
Subject: Proxy Server Using TCL (Please disregard previous post, forgot non-binary group! =-) From: [EMAIL PROTECTED] 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: [EMAIL PROTECTED] 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 - [EMAIL PROTECTED] # 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 {\&} str; regsub -all "<" $str {\<} str; regsub -all ">" $str {\>} str; regsub -all \" $str {\"} 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:[EMAIL PROTECTED]\"> </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:[EMAIL PROTECTED]\"> </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\">©</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 - [EMAIL PROTECTED] - 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 [EMAIL PROTECTED] 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 <= 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=dnserver&[EMAIL PROTECTED]%3e%231/8 We hope to see you soon at Deja.com. Before you buy. http://www.deja.com/%5bST_rn%3dap%5d/
