#!/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@www.box.eu.org # 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
\n[txt2html $what]
" \ 400 "Bad Request"; return; } if {![regexp {^(GET|HEAD|POST)$} $method]} { # not implemented method serror $file \ "Sorry, the method $method is not implemented.\n\

Your query was\n

\n[txt2html $what]
" \ 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\

Your query was\n

\n[txt2html $queue($file)]
" \ 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 "
$url
" 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 "
$apline
" 500 "Invalid Proxy Ctrl Version"; return; } if {[catch {llength $aplist} lg]} { serror $file "
$aplist
" 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 "
$thisproxy
" 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

Try to reload 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 $title

$title

$msg
Anonymous proxy httpd v$version server in tcl, by dl
" } do_close $file "error ($id $title)"; } proc htmlblah {file getflag title msg} { global version; set sendstr "$title

$title

$msg
Anonymous proxy httpd v$version server in tcl, © by dl
" 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, please), source is here and latest version and informations are on http://www.box.eu.org/~dl/wwwtools.html.

Use setenv http_proxy http://$fqhn:$port/ to use it, or better, run a local copy and join the privacy http proxy network.

Access restricted proxy admin.

Look at the amount of information your browser is sending (and this proxy is throwing away) :
See for instance the Referer: that might contain very personal informations (back links). (Not all browsers put a Referer field, though)

$what

Currently: $nbrconn/$absmaxconn open connections,
Free buffers: $freebuflst
Served a total of $count requests since $dateup
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@mail.box.eu.org - 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@www.box.eu.org 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

Number of hops (must be <= number of proxies in the route list):

Proxy route list (each proxy as host:port):

Allow Post:

Currently: $nbrconn/$absmaxconn open connections,
Free buffers: $freebuflst
Served a total of $count requests since $dateup
Proxy requests: $pcount, transmitted [format %.1f $trkbytes] kbytes

Back to server root " } # 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