Perl HTTPD Proxy. . .
/etc/apache2/apache2.conf:
# KeepAlive: Whether or not to allow persistent connections (more than # one request per connection). Set to "Off" to deactivate. # #### commented out, line below added 2010 May 06 ##############KeepAlive On KeepAlive Off
The Script!
#!/usr/bin/perl -T -w # -- Notes : ---------------------------------------------------------------------- # 1. do not mix sysread and read on a file handle (similarly for writes/porints); # 2. # # use strict; # -- Get the remote host : -------------------------------------------------------- use Socket; # -- xinetd on RedHat 9.0 passes REMOTE_HOST through, inetd on Debian Woody # does not; getpeername is more reliable... # #unless ($ENV{"REMOTE_HOST"} =~ m/^(\d\d?\d?\.\d\d?\d?\.\d\d?\d?\.\d\d?\d?)$/) { # die "\n\n R \n\n"; # } # #$ENV{"REMOTE_HOST"} = $1; my $peername = getpeername(STDIN); my ($peerport, $peeraddr) = Socket::unpack_sockaddr_in($peername); $peeraddr = inet_ntoa($peeraddr); $ENV{"REMOTE_HOST"} = $peeraddr; ##foreach (keys %ENV) { ## print "\n $_ " . $ENV{$_}; ## } ##exit; # -- Tighten up environment : ----------------------------------------------------- $ENV{PATH} = ""; # -- Config : --------------------------------------------------------------------- my $EMERGENCY = 0; # ...if we've shagged it up, set = 1 for a temp workaround... my $DEBUG = 1; # ...if we're stuck... my $IPT = "/sbin/iptables"; my $apache_port = 8999; # -- Imports : -------------------------------------------------------------------- use Sys::Syslog; use IPC::Open2; ##use Fcntl; ##use POSIX; # ...Fcntl, with POSIX, used for when non-blocking IO was being played with... # -- The "Oh I've shagged it up section : ----------------------------------------- # ...simple pass-through case for when have fucked-up the real version, # i.e., all that code below : if ($EMERGENCY) { ### system("/home/si2/netcat/nc -w 10 talby.csu.umist.ac.uk 8999"); system("/home/si2/netcat/nc -w 10 talby.rcs.manchester.ac.uk 8999"); exit 0; } # -- Log who's calling us : ------------------------------------------------------- # ...do this right near the beginning just in case we get shagged (and note # that with any luck xinetd is already doing some logging too)... openlog("httpproxy", "ndelay", "daemon"); syslog("notice", $ENV{"REMOTE_HOST"} . " ...is making a request..."); closelog(); # -- Debug initialisation : ------------------------------------------------------- if ($DEBUG) { `echo "" > /tmp/HTTPPROXY_ETC`; `echo "" > /tmp/HTTPPROXY_ERR`; `echo "" > /tmp/HTTPPROXY_OUT`; } # -- Read request from STDIN : ---------------------------------------------------- # ...this was required when using std perl read to get request; not required # with sysread... # my $flags = ''; # fcntl(STDIN, F_GETFL, $flags) or die "\n\n Couldn't get flags for STDIN \n\n"; # $flags |= O_NONBLOCK; # fcntl(STDIN, F_SETFL, $flags) or die "\n\n Couldn't set flags for STDIN \n\n"; # ...here be a suggestion of that std read type code : # while ($xx = <STDIN>) { # unless (defined $xx) { exit } # $input .= $xx; # } # -- Read request from STDIN using nice low-level sys stuff: ---------------------- my $request = ""; my $nbytes = 0; $nbytes = sysread(STDIN, $request, 10240); # ...10k should be enough for any conceivable request... if ($DEBUG) { open(TMP, ">>/tmp/HTTPPROXY_ETC") || die "\n\n Can't open ETC \n\n"; print TMP "\n" . time . " -- Read request from STDIN..."; close(TMP); } if ($DEBUG) { open(TMP, ">/tmp/HTTPPROXY_REQ") || die "\n\n Can't open REQ \n\n"; print TMP "\n" . time . " -- $request"; close(TMP); # ...save everything about the request, including all headers (debug)... } # -- Grab main parts of request : ------------------------------------------------- my ($req_0, $req_1, $req_2) = split(/\s+/, $request); my (undef, @req_rest) = split(/\n/, $request); unless (defined $req_0) {$req_0 = ""} unless (defined $req_1) {$req_1 = ""} unless (defined $req_2) {$req_2 = ""} # -- Log main parts of request : -------------------------------------------------- openlog("httpproxy", "ndelay", "daemon"); my $ssss = $ENV{"REMOTE_HOST"} . " $req_0 $req_1 $req_2"; $ssss =~ s/%//g; syslog("notice", $ssss); closelog(); # -- We don't do these : ---------------------------------------------------------- if ( ($req_0 eq "OPTIONS") || ($req_0 eq "SEARCH") || ($req_0 eq "TRACE") || ($req_0 eq "LINK") || ($req_0 eq "UNLINK") || ($req_0 eq "PUT") || ($req_0 eq "DELETE")){ &when_in_doubt_do_nowt("DOUBTFUL METHOD", "$req_0 $req_1 $req_2"); } # -- Be a safety-girl : ----------------------------------------------------------- # ...check out that request for nasties they are attempting to stick us with... unless (($req_0 =~ m/^GET$/) || ($req_0 =~ m/^HEAD$/) || ($req_0 =~ m/^POST$/)) { &deathblock("UNKNOWN HEADER", "$req_0 $req_1 $req_2"); # ...we handle only GET, HEAD and POST at present... } unless (($req_2 =~ m/^HTTP\/1.0$/) || ($req_2 =~ m/^HTTP\/1\.1$/)) { &deathblock("UNKNOWN HTTP [$req_2]", "$req_0 $req_1 $req_2"); # ...ensure we are talking the same language... } unless (length($req_1) < 150) { &deathblock("TOO LONG", "$req_0 $req_1 $req_2"); # ...buffer overloads... } if ($req_1 =~ m/\.\./) { &deathblock("DOTS", "$req_0 $req_1 $req_2"); # ...don't allow this "dir/../other" sort of thing... } # -- Nuke chars we don't like : --------------------------------------------------- $req_1 =~ s/[{}|\`^\\\[\]]//g; # ...unsafe chars which should always be encoded: { } | \ ^ ~ [ ] ` # so we should not see them; we simply erase them, except for ~ which # we need... $req_1 =~ s/%5B|%5C|%5D|%7B|%7D|%5E|%60|%7C//g; # ...browsers automatically convert these chars to hex-encodings, often, # so we erase them too: [ %5B, ] %5D, \ %5C, { %7B, } %7D, # ^ %5E, ` %60, | %7C (again, leave ~ %7E alone)... $req_1 =~ s/[:;@]//g; $req_1 =~ s/%3A|%3B|%40//g; # ...reserved chars: ; / ? : @ = & so should be allowed, but we don't # like ; %3B : %3A @ %40 so we nuke them... # $req_1 =~ s/[\$!\*\,]//g; $req_1 =~ s/%21|%2A|%2C|%24//g; # ...okay chars are supposed to be: # # 1. alphanumerics # 2. $ - _ . + ! * ' , ( ) # 3. reserved chars used for their reserved purposes # # so should be allowed, but we don't like $ %24 # ! %21 * %2A , %2C so we nuke them (apparently # + can be used to imply space, so we allow that and we allow # parentheses since we have some e-Learning stuff with them)... $req_1 =~ s/[\"\<\>]//g; $req_1 =~ s/%22|%3C|%3E//g; # ...special chars % # " < > ...we allow the first two but don't like # the other three... ### __TODO__ ### __TODO__ # ...log nuking... if ($DEBUG) { open(TMP, ">>/tmp/HTTPPROXY_ETC") || die "\n\n Can't open ETC \n\n"; print TMP "\n" . time . " -- //$req_1//"; close(TMP); } # -- Send nice, safe request on its way : ----------------------------------------- my $output = "$req_0 $req_1 $req_2\n"; foreach (@req_rest) {$output .= "$_\n"} if ($DEBUG) { # print "<HTML><BODY><PRE>$output" . "EEOOTT</PRE></BODY></HTML>"; # exit 0; } #open(OUTPUT, "| /home/simonh/src/nc-110/nc -w 10 127.0.0.1 8999"); #print OUTPUT "$output\n\n\n"; # ...old version: the sending of the request to apache seemed ok, but we did # not always get everything expected back using std "read" --- perhaps # should have used sysread (and the latter carefully)... if ($DEBUG) { open(TMP, ">>/tmp/HTTPPROXY_ETC") || die "\n\n Can't open ETC \n\n"; print TMP "\n" . time . " -- Gonna send request to apache2 via nc..."; close(TMP); } ###open2(*READ2, *WRITE2, "/home/si2/netcat/nc -w 10 talby.csu.umist.ac.uk 8999"); ############################open2(*READ2, *WRITE2, "/home/si2/netcat/nc -w 10 mctalby.mc.man.ac.uk 8999"); open2(*READ2, *WRITE2, "/bin/nc -w 10 talby.rcs.manchester.ac.uk 8999"); print WRITE2 $output; # ...send request to apache via netcat... if ($DEBUG) { open(TMP, ">>/tmp/HTTPPROXY_ETC") || die "\n\n Can't open ETC \n\n"; print TMP "\n" . time . " -- Request sent to apache2 via nc..."; close(TMP); } if ($DEBUG) { open(TMP, ">>/tmp/HTTPPROXY_ETC") || die "\n\n Can't open ETC \n\n"; print TMP "\n" . time . " -- Gonna read reply from apache2 via nc..."; close(TMP); } # -- Read stuff sent back from netcat : ------------------------------------------- my $r2_blocksize = (stat READ2)[11] || 16384; my $buffer = ""; my $read_2 = ""; while (my $len = sysread READ2, $buffer, $r2_blocksize) { if (!defined $len) { openlog("httpproxy", "ndelay", "daemon"); syslog("notice", "System read error: $!"); closelog(); next if $! =~ /^Interrupted/; die "\n\n System read error: $! \n\n"; } $read_2 .= $buffer; if ($DEBUG) { open(TMP, ">>/tmp/HTTPPROXY_ETC") || die "\n\n Can't open ETC \n\n"; print TMP "\n" . time . " -- Read a block..."; close(TMP); } } close(WRITE2); close(READ2); if ($DEBUG) { open(TMP, ">>/tmp/HTTPPROXY_ETC") || die "\n\n Can't open ETC \n\n"; print TMP "\n" . time . " -- Read reply from apache2 via nc..."; close(TMP); } # -- Debug : ---------------------------------------------------------------------- if ($DEBUG) { open(TMP, ">/tmp/HTTPPROXY_OUT") || die "\n\n Can't open TMP. \n\n"; print TMP $read_2; close(TMP); # ...don't use `echo...` for this as may contain binary which screws up # in the shell... } # -- Send output on its way to remote host : -------------------------------------- $read_2 =~ s/\:$apache_port//; # ...some versions of apache (e.g., 1.3.31, Debian Sarge) attach, unasked, # port number on URLs (e.g., 8999) which messes things up... my $written = syswrite STDOUT, $read_2, length($read_2), 0; ## -- error handling?? ## -- if ($written < length($read_2)) { ## do something; if ($DEBUG) { open(TMP, ">>/tmp/HTTPPROXY_ETC") || die "\n\n Can't open ETC \n\n"; print TMP "\n" . time . " -- Reply sent to remote host..."; close(TMP); } # --------------------------------------------------------------------------------- # -- The End : exit 0; # --------------------------------------------------------------------------------- sub when_in_doubt_do_nowt() { my $error = shift; my $string = shift; $error =~ s/%//g; $string =~ s/%//g; # ...don't want to confuse syslog's implementation with "%"s... openlog("httpproxy", "ndelay", "daemon"); syslog("notice", $ENV{"REMOTE_HOST"} . " * " . $error . " * "); syslog("notice", $ENV{"REMOTE_HOST"} . " " . $string); closelog(); die "\n\n Why can't you say something righteous and hopeful for a change? \n\n"; } sub deathblock() { my $error = shift; my $string = shift; $error =~ s/\%//g; $string =~ s/\%//g; # ...don't want to confuse syslog's implementation with "%"s... openlog("httpproxy", "ndelay", "daemon"); syslog("notice", $ENV{"REMOTE_HOST"} . " *** " . $error . " ***"); syslog("notice", $ENV{"REMOTE_HOST"} . " *** " . $string); closelog(); # -- they've been naughty so invoke IPTables block : print "\n\n Woof-woof-woof! \n\n"; system("$IPT -t filter -I INPUT -s $ENV{REMOTE_HOST} -j DROP"); die "\n\n That's my other dog impersonation! \n\n"; } # --------------------------------------------------------------------------------- # ---------------------------------------------------------------------------------