# -*- mode: perl -*-

#Copyright Massachusetts Institute of Technology, 2003.
#Written by Eric Prud'hommeaux for the World Wide Web Consortium
#Kudos to Doug Bagley for htprox, upon which this is based.

# $Id: Proxy.pm,v 1.12 2005/02/07 09:12:12 eric Exp $

$REVISION = '$Id: Proxy.pm,v 1.12 2005/02/07 09:12:12 eric Exp $ ';

use strict;

package W3C::Http::Proxy;

use Symbol qw(gensym);
use Socket;
use POSIX qw(setsid);

use W3C::Util::Exception;
use W3C::Http::Message;
use W3C::Http::ProxySession qw(%EVENT_Strs $SUMMARY $ERROR $SOCKETS $OBJECTS $PROTOCOL $SELECT $DAEMON $PROXY_ACTION $DEBUG);
use W3C::Http::Exception;
use W3C::Util::Logger;

sub new {
    my ($proto, $host, $port, $timeout, $logger) = @_;
    my $class = ref $proto || $proto;
    my $self = {HANDLERS => {}, 
		HOST => $host, 
		PORT => $port, 
		# the select bits
		WRITERS => '', 
		READERS => '', 
		TIMEOUT => $timeout, 
		LOGGER => $logger ? $logger : 
		    new W3C::Util::Logger(-handles => {$PROTOCOL => undef, 
						       $SELECT => undef},
					  -default => \*STDERR), 
		};
    bless ($self, $class);
    return $self;
}

sub registerWriter {
    my ($self, $socket) = @_;
    vec($self->{WRITERS}, fileno($socket), 1) = 1;
}

sub main {
    my ($self, $forground, $pidFile) = @_;

    if ($forground) {
	$self->runLoop();
    } else {
	if (open(PF, "<$pidFile")) {
	    my $serverpid = <PF>;
	    close(PF);
	    if ($serverpid && kill(0, $serverpid) && !kill(3, $serverpid)) {
		&throw(new W3C::Util::Exception(-message => "Server is already running (pid == $serverpid)"));
	    }
	}
	if ($self->{Pid} = fork()) {
	    $self->forkParent($self->{Pid});
	    exit(0);
	} elsif (!defined $self->{Pid}) {
	    &throw(new W3C::Util::Exception(-message => "fork failed: $!"));
	} else {
	    close(STDIN);
	    close(STDOUT);
	    close(STDERR);
	    $self->forkChild();
	    $self->log($DAEMON, "started @{[scalar(localtime)]}");
	    &setsid();
	    umask(0);
	    eval qq{
		END {
		    # cleanup here
		    $self->log($DAEMON, "EXITING: ", scalar(localtime));
		    if (unlink(\$pidFile)) {
			$self->log($DAEMON, "Removed pidfile \$pidFile");
		    } else {
			$self->log($DAEMON, "Error, unable to remove pidfile \$pidFile");
		    }
		}
	    };
	    if (open(PF, ">$pidFile")) {
		print PF $$;
		close(PF);
	    } else {
		&throw(new W3C::Util::Exception(-message => "unable to write pidfile: $pidFile ($!)"));
	    }
	    $self->runLoop();		# does not return unless signalled
	}
    }
}

sub forkParent {
    my ($self) = @_;
}

sub forkChild {
    my ($self) = @_;
}

sub createListenSocket {
    my ($self) = @_;
    my $host = $self->{HOST};
    my $port = $self->{PORT};
    my $sock = gensym();
    if (!socket($sock, AF_INET, SOCK_STREAM, 0)) {
	&throw(new W3C::Util::Exception(-message => "error, could not make listen socket for $host:$port ($!)"));
    }
    if (!setsockopt($sock, SOL_SOCKET, SO_REUSEADDR, pack("L", 1))) {
	&throw(new W3C::Util::Exception(-message => "error, could not set listen socket for REUSEADDR ($!)"));
    }
    if ($host) {
	if (!bind($sock, pack_sockaddr_in($port, inet_aton($host)))) {
	    &throw(new W3C::Util::Exception(-message => "error, could not bind listen socket to address $host:$port ($!)"));
	}
    } else {
	if (!bind($sock, sockaddr_in($port, INADDR_ANY))) {
	    &throw(new W3C::Util::Exception(-message => "error, could not bind listen socket to address $host:$port ($!)"));
	}
    }
    if (!listen($sock, 1024)) {
	&throw(new W3C::Util::Exception(-message => "error, could not listen on socket: $host:$port ($!)"));
    }
    return($sock);
}

# Called either as child or in main (only) thread mode.
sub beforeEventLoop {
    my ($self) = @_;
    # chdir('/');
}

sub runLoop {
    my ($self) = @_;

    $self->beforeEventLoop();
    my $lsock = $self->createListenSocket();
    vec($self->{READERS}, fileno($lsock), 1) = 1;
    my $rdbits;
    my $wrbits;
    my %conn = ();

    # hashes to keep track of current client/server connections
    my %CLIENT = ();
    my %SERVER = ();

    while (1) {
	my $nc = scalar keys %CLIENT;
	my $ns = scalar keys %SERVER;
	#$0 = "annoprox($self-{PORT}): CS=$nc SS=$ns";
	my $nfound = select($rdbits = $self->{READERS}, $wrbits = $self->{WRITERS}, undef, $self->{TIMEOUT});
	$self->perLoop();
	#print "select: nfound = $nfound  readbits = ", unpack("b*", $rdbits), "  writebits = ", unpack("b*", $wrbits), "\n";
	%conn = ( fileno($lsock) => $lsock );
	while (my($key, $R) = each %CLIENT) {
	    $conn{fileno($R->{ClientSock})} = $R->{ClientSock} if ($R->{ClientSock});
	    $conn{fileno($R->{ServerSock})} = $R->{ServerSock} if ($R->{ServerSock});
	}
	#sleep(1); # @@@
	while (my($sockno, $sock) = each %conn) {
	    # process readable sockets
	    my $R;
	    eval {
		if (vec($rdbits, $sockno, 1) == 1) {
		    if($sock == $lsock) {
			# accept a new socket from client
			my $new = gensym();
			if (my $clientaddr = accept($new, $lsock)) {
			    $self->log($SOCKETS, "new client connection accepted: $new");
			    # add new client to $self->{READERS}
			    vec($self->{READERS}, fileno($new), 1) = 1;
			    $self->log($OBJECTS, "New Client in READERS (fileno=@{[fileno($new)]})");
			    my $ip = inet_ntoa((unpack_sockaddr_in($clientaddr))[1]);
			    $CLIENT{$new} = $self->createSession($new, $ip);
			} else {
			    &throw(new W3C::Util::Exception(-message => "error in accept() ($!)"));
			}
		    } elsif ($R = $CLIENT{$sock}) {
			$self->log($PROTOCOL, "STEP 1: reading request from client");
			if ($R->readFromClient()) {
			    $self->log($PROTOCOL, "STEP 1: DONE reading request from client");
			    $R->processRequest();
			    # remove client from $self->{READERS}
			    vec($self->{READERS}, $sockno, 1) = 0;

			    # then start a non-blocking connect to the server.
			    my $newsock = $R->nonBlockingConnect();

			    # point SERVER socket to REQUEST
			    $SERVER{$newsock} = $R;
			    # (adds server to $self->{WRITERS})
			    vec($self->{WRITERS}, fileno($newsock), 1) = 1;
			}
		    } elsif ($R = $SERVER{$sock}) {
			my $reply_complete = $R->readFromServer();
			#if (0 && (!$reply_complete || $transferTerminate) && !$R->{Buffering}) {
			#    #$self->log($PROTOCOL, "READ $R->{ContentType} $nread bytes from server");
			#    # set up for writing what we just read from server back to client
			#    vec($self->{WRITERS}, fileno($R->{ClientSock}), 1) = 1;
			#    $self->log($SELECT, "client in WRITERS (fileno=@{[fileno($R->{ClientSock})]}, for readFromServer");
			#}
			$R->setupResponseForClient();
			if ($reply_complete) {
			    if ($R->{Handler}) {
				$R->processReply();
			    }
			    # we're done reading from server so remove server socket 
			    #from READERS select bits
			    vec($self->{READERS}, $sockno, 1) = 0;
			    if (defined($R->{ClientSock})) {
				# (ClientSock wont' be defined if there was an error)
				# set up client for writing
				vec($self->{WRITERS}, fileno($R->{ClientSock}), 1) = 1;
				$self->log($SELECT, "client in WRITERS (fileno=@{[fileno($R->{ClientSock})]}, for step 3");
				# initialize buffer info for writing reply to client
				$R->{WriteLength} = length($R->{Buffer});
				$R->{WriteOffset} = 0;
			    }
			}
		    }
		}
		# process writeable sockets
		if (vec($wrbits, $sockno, 1) == 1) {
		    if ($R = $CLIENT{$sock}) {
			$self->log($PROTOCOL, "STEP 4: write reply to client");
			if ($R->writeToClient()) {
			    $self->log($PROTOCOL, "STEP 4: DONE writing reply to client");
			    # done?
			    &throw(new W3C::Http::Proxy::CloseSocketException());
			} elsif (!$R->{Buffering}) {
			    vec($self->{WRITERS}, fileno($R->{ClientSock}), 1) = 0;
			}
		    } elsif ($R = $SERVER{$sock}) {
			if ($R->{Connecting}) {
			    $self->log($PROTOCOL, "STEP 2a: handle successful connect to server");
			    $R->{Connecting} = 0;
			} else {
			    $self->log($PROTOCOL, "STEP 2b: write request to server");
			    if ($R->writeToServer()) {
				$self->log($PROTOCOL, "STEP 2b: DONE writing request to server");
				# remove server socket from $self->{WRITERS}
				vec($self->{WRITERS}, $sockno, 1) = 0;
				# and add server to $self->{READERS} so we can read the reply
				vec($self->{READERS}, $sockno, 1) = 1;
				$self->log($SELECT, "New Server in READERS (fileno=$sockno)");
				$R->{Buffer} = '';
				$R->{ReadOffset} = 0;
			    }
			}
		    }
		}
	    }; if ($@) {if (my $ex = &catch('W3C::Http::HttpMessageException')) {
		$R->{Buffer} = $ex->getHttpMessage->toString;
		$R->{WriteLength} = length($R->{Buffer});
		$R->{WriteOffset} = 0;
		# add client socket to writers
		vec($self->{WRITERS}, fileno($R->{ClientSock}), 1) = 1;
		$self->log($SELECT, "New Client in WRITERS (fileno=@{[fileno($R->{ClientSock})]}, for errorpage)");
	    } elsif (my $ex = &catch('W3C::Util::Exception')) {
		if (!$ex->isa('W3C::Http::Proxy::CloseSocketException')) {
		    $self->log($ERROR, $ex->toString());
		}
		if (my $clientsock = $R->{ClientSock}) {
		    my $fileno = fileno($clientsock);
		    vec($self->{READERS}, $fileno, 1) = 0;
		    vec($self->{WRITERS}, $fileno, 1) = 0;
		    $self->log($SELECT, "Done with client (fileno=@{[fileno($R->{ClientSock})]})");
		    close($clientsock);
		    delete $CLIENT{$clientsock};
		}
		if (my $serversock = $R->{ServerSock}) {
		    my $fileno = fileno($serversock);
		    vec($self->{READERS}, $fileno, 1) = 0;
		    vec($self->{WRITERS}, $fileno, 1) = 0;
		    close($serversock);
		    delete $SERVER{$serversock};
		}
		$R->{ServerSock} = $R->{ClientSock} = undef;
	    } else {&throw()}}
	}
    }
}

sub createSession {
    my ($self, $new, $ip) = @_;
    return new W3C::Http::ProxySession($self, $new, $ip);
}

sub perLoop {
    my ($self) = @_;
}

sub enableSignals {
    my ($self, %h) = @_;
    $SIG{HUP} = $h{HUP} ? $h{HUP} : 'IGNORE';
    $SIG{PIPE} = $h{PIPE} ? $h{PIPE} : 'IGNORE';
    $SIG{QUIT} = sub {&throw(new W3C::Util::SignalException(-pid => $self->{Pid}, -signal => 'SIGQUIT'));};
    $SIG{SEGV} = $SIG{QUIT};
}

sub addHandler {
    my ($self, $contentType, $handler, $buffering, $starter) = @_;
    $self->{HANDLERS}{$contentType} = [$handler, $buffering, $starter];
}

sub getHandler {
    my ($self, $contentType, $R) = @_;
    if ($self->{HANDLERS}{$contentType} and (my($handler, $buffering, $starter) = @{$self->{HANDLERS}{$contentType}})) {
	return ($handler, $buffering, $starter);
    } else {
	return undef;
    }
}

sub log {
    my ($self, $event, @args) = @_;
    $self->{LOGGER}->log($event, "$EVENT_Strs{$event}: ", @args);
}

sub killProxy { # static
    my ($pidFile) = @_;
    if (open(PF, "<$pidFile")) {
	my $serverpid = <PF>;
	close(PF);
	if ($serverpid) {
	    if (kill(3, $serverpid)) {
		print("Killed server $serverpid\n");
		if (open(PF, ">$pidFile")) {
		    close(PF);
		}
	    } else {
		print("Unable to kill server (pid == $serverpid)\n");
	    }
	} else {
	    print("No process found in PID file \"$pidFile\"\n");
	}
    } else {
	print("Unable to read PID file \"$pidFile\"\n");
    }
}

1;

__END__

=head1 NAME

W3C::Http::Proxy - extensible HTTP proxy

=head1 SYNOPSIS

    package annoprox;
    @annoprox::ISA = qw(W3C::Http::Proxy);

    sub createSession {
        my ($self, $new, $ip) = @_;
        return new W3C::Http::ProxySession($self, $new, $ip);
    }

    eval {
        my $proxy = new annoprox(undef, 8888, 5);
        #use sigtrap qw(die normal-signals);
        $proxy->enableSignals(HUP => sub {$proxy->{HUPPED}++});
        $proxy->addHandler('text/html', 
                           \&annoProxSession::htmlHandler, 1, undef);
        $proxy->main($ARGV[0], $PidFile);
    }; if ($@) {if (my $ex = &catch('W3C::Util::Exception')) {
    	die $ex->toString;
        } else {
    	die $@;
        }
    }

=head1 DESCRIPTION

This is an experimental proxy. It seems to have some lockups in certain pilelining scenarios.

This module is part of the W3C::Http CPAN module.

=head1 AUTHOR

Eric Prud'hommeaux <eric@w3.org>

=head1 SEE ALSO

L<W3C::Http::ProxySession>

=cut
