# -*- 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: ProxySession.pm,v 1.6 2004/11/26 16:25:41 eric Exp $

$REVISION = '$Id: ProxySession.pm,v 1.6 2004/11/26 16:25:41 eric Exp $ ';
use strict;
require Exporter;

# Exception class tree
@W3C::Http::Proxy::CloseSocketException::ISA = qw(W3C::Util::Exception);
@W3C::Http::Proxy::UnexpectedCloseSocketException::ISA = qw(W3C::Http::Proxy::CloseSocketException);
@W3C::Http::Proxy::ClientReadException::ISA = qw(W3C::Http::Proxy::UnexpectedCloseSocketException);
@W3C::Http::Proxy::ClientWriteException::ISA = qw(W3C::Http::Proxy::UnexpectedCloseSocketException);
@W3C::Http::Proxy::ServerReadException::ISA = qw(W3C::Http::Proxy::UnexpectedCloseSocketException);
@W3C::Http::Proxy::ServerWriteException::ISA = qw(W3C::Http::Proxy::UnexpectedCloseSocketException);

sub proxyError {
    my ($message) = @_;
    my $title = 'Request Error';
    my $data = "<html><head><title>$title</title></head>
      <body><h1>$title</h1>
            <p>$message</p>
      </body>
</html>\n";
    my $contentLength = length $data;
    my @date = split (/\s+/, scalar gmtime());
    my $date = join (' ', $date[0].',', @date[2, 1, 4, 3], 'GMT');
    my $headers = [['Connection', 'close'], 
		   ['Content-type', 'text/html'], 
		   ['Content-length', length($data)], 
		   ['Expires', $date]];
    my $m = new W3C::Http::Message(-statusCode => 500, -headers => $headers, -body => $data);
    return new W3C::Http::HttpMessageException(-httpMessage => $m);
}


package W3C::Http::ProxySession;
@W3C::Http::ProxySession::ISA = qw(Exporter);
use vars qw(@EXPORT_OK);
use vars qw(%EVENT_Strs);
use vars qw($SUMMARY $ERROR $SOCKETS $OBJECTS $PROTOCOL $SELECT $DAEMON $PROXY_ACTION $DEBUG);
@EXPORT_OK = qw(%EVENT_Strs $SUMMARY $ERROR $SOCKETS $OBJECTS $PROTOCOL $SELECT $DAEMON $PROXY_ACTION $DEBUG);
($SUMMARY, $SOCKETS, $OBJECTS, $PROTOCOL, $SELECT, $DAEMON, $PROXY_ACTION, $DEBUG) = (1..8);
%EVENT_Strs = ($SUMMARY => '.', $ERROR => '!', $SOCKETS => 'SOCKETS', $OBJECTS => 'OBJECTS', $PROTOCOL => 'PROTOCOL', $SELECT => 'SELECT', $DAEMON => 'DAEMON', $PROXY_ACTION => 'PROXY_ACTION', $DEBUG => 'DEBUG');

use Fcntl;
use Symbol qw(gensym);
use Socket;
use POSIX qw(EINPROGRESS);
use Errno qw(EINTR EAGAIN EWOULDBLOCK);;

use W3C::Util::Exception;
sub new {
    my ($proto, $proxy, $clientSock, $clientIp) = @_;
    my $class = ref $proto || $proto;
    my $self = {Start => time, # mark start_time
		ClientSock => $clientSock,
		Connecting => 0, # connecting to server
		ServerSock => undef,
		State => undef,
		Buffer => '',
		ReadOffset => 0,
		WriteOffset => 0,
		WriteLength => 0,
		TotalRead => 0,
		TotalWritten => 0,
		ClientIP => $clientIp,
		PROXY => $proxy,
	    };
    bless ($self, $class);
    return $self;
}

sub nonBlockingConnect {
    my($self) = @_;
    my $sock = gensym();
    if (!socket($sock, AF_INET, SOCK_STREAM, 0)) {
	&throw(new W3C::Util::Exception(-message => "error, could not make socket for $self-{Host}:$self->{Port} ($!)"));
    }
    if (!fcntl($sock, F_SETFL, O_NONBLOCK)) {
	&throw(new W3C::Util::Exception(-message => "error, could not make socket non-blocking for $self->{Host}:$self->{Port} ($!)"));
    }
    my $addr = inet_aton($self->{Host});
    if (!$addr) {
	&throw(new W3C::Util::Exception(-message => "Can't resolve: $self->{Host}"));
    }
    if (!connect($sock, &sockaddr_in($self->{Port}, $addr)) && $! != EINPROGRESS) {
	&throw(new W3C::Util::Exception(-message => "error on connect() to $self->{Host}:$self->{Port} ($!)"));
    }
    $self->{ServerSock} = $sock;
    $self->{Connecting} = 1;

    # Initialize buffer info for write to server.
    $self->{WriteLength} = length($self->{Buffer});
    $self->{WriteOffset} = 0;
    return ($sock);
}


sub processRequest {
    my ($self) = @_;
    my($headers, $content) = ($self->{Buffer} =~ /^(.*?\r?\n\r?\n)(.*)$/s);
    if (!$headers) {
	&throw(&main::proxyError("MALFORMED CLIENT REQUEST, NO BLANK LINE FOUND:\n$self->{Buffer}"));
    }
    my $oldheaders = $headers;
    $headers =~ s! HTTP/\d+\.\d+\r?\n! HTTP/1.0\r\n!;
    $headers =~ s/Proxy-\S+: [^\r\n]*\r?\n//i;
    $headers =~ s/Keep-Alive: [^\r\n]+\r?\n//i;
    $headers =~ s/Connection: [^\r\n]+\r?\n//i;
    $headers =~ s/Accept-Encoding: [^\r\n]+\r?\n//i;
    $headers =~ s/\r?\n\r?\n/\r\nConnection: close\r\n\r\n/i;

    # after we've read the proxy request from the client, we have to
    # reformat the HTTP request line from a proxy request into a regular request
    my($request_line, $request_body) = split(/\r?\n/, $headers, 2);

    # log access
    $self->{PROXY}->log($SUMMARY, "$self->{ClientIP} [", scalar(localtime), "] $request_line\n");
    if ($request_line !~ m!^(\S+)\s+(http://([^:/\s]+):?(\d+)?(\S*)([^\r\n ]*))(?: ([^\r\n ]*))!i) {
	&throw(&main::proxyError("Unrecognized request line:\n$headers"));
    }
    my $method = $1;
    $self->{URI} = $2;
    $self->{Host} = $3;
    $self->{Port} = $4 || 80;
    my $path = $5 || '/';
    my $rest = $7;
    $self->{PROXY}->log($PROTOCOL, "parsed request Host=$self->{Host}  Port=$self->{Port}  Path=$path");
    $self->{PROXY}->log($PROTOCOL, "NEW REQUEST is: $method $path $rest");
    # rewrite request so it is no longer a proxy request
    $request_line = "$method $path $rest\r\n";
    $self->{PROXY}->log($PROTOCOL, "new request line: $request_line");
    $headers = $request_line . $request_body;

    # apply those features that affect the sending of client headers
    $self->{Buffer} = $headers . $content;
}


sub processReply {
    # processReply is only called after the full reply is read
    my ($self) = @_;
    if (not $self->{ReplyHeaders}) {
	&throw(new W3C::Util::Exception(-message => "MALFORMED SERVER REPLY, NO BLANK LINE FOUND:\n$self->{Buffer}"));
    }
    my $content = substr($self->{Buffer}, length($self->{ReplyHeaders}));
    # call the content-type specific handler
    my $callback = $self->{Handler};
    $self->$callback(\$content);
}


sub setupResponseForClient {
    my $self = shift;
    return if ($self->{ReplyHeaders});
    # check if we have received complete headers
    if ($self->{Buffer} =~ /^(.*?\r?\n\r?\n)/s) {
	# and when we do...
	# check to see if bogus server has returned html content
	# without http headers
	my $hd = $1;
	my $contentType;
	my $contentLength;
	if ($hd =~ /\n[\w-]+: \S/) {
	    if ($hd =~ /\ncontent-type: ([^;\r\n]+)/i) {
		$contentType = $1;
		($contentLength) =
		    ($self->{ReplyHeaders} =~ /\ncontent-length: (\d+)/i);
	    }
	} elsif ($hd !~ /^HTTP\S+ \d+/) {
	    # guess the content type
	    $self->{PROXY}->log($PROXY_ACTION, "faking reply headers for: $hd");
	    $contentType = 'text/html' if ($hd =~ /<(?:html|body)/i);
	    $hd = "HTTP/1.1 200 OK\r\n";
	    $hd .= "Content-type: $contentType\r\n" if ($contentType);
	    $self->{Buffer} = $hd . "\r\n" . $self->{Buffer};
	}
	$self->{ReplyHeaders} = $hd;
	#print "\nSERVER HEADERS:\n$self->{ReplyHeaders}\n" if ($OPT{serverheaders});
	$self->{WriteOffset} = 0;
	$self->{Parallel} = 1;
	#if ($HANDLERS{$contentType} and (my($handler, $maxsize) = @{$HANDLERS{$contentType}})) {
	my ($handler, $maxsize, $starter) = $self->{PROXY}->getHandler($contentType, $self);
	if ($handler) {
	    if ((not $maxsize) or ($contentLength <= $maxsize)) {
		$self->{PROXY}->log($PROXY_ACTION, "setting handler for $contentType");
		$self->{Handler} = $handler;
		$self->{Parallel} = 0;
		$self->$starter() if ($starter);
	    } else {
		$self->{PROXY}->log($PROXY_ACTION, "$contentType size $contentLength exceeds maxsize $maxsize, passing thru");
	    }
	} else {
	    # if no special handler is specified reply is just returned
	    # directly to client
	    $self->{PROXY}->log($PROXY_ACTION, "no registered handler for $contentType");
	    $self->{PROXY}->log($PROTOCOL, "headers==\n$self->{ReplyHeaders}");
	}
	$self->{ContentType} = $contentType;
    }
}

sub readFromClient {
    my ($self) = @_;
    # read GET or POST
    # read until blank line or Content-Length
    my $nread = sysread($self->{ClientSock}, $self->{Buffer}, 4096, $self->{ReadOffset});
    if ($nread > 0) {
	$self->{ReadOffset} += $nread;
	# TBD - handle PUT/other methods?
	if ($self->{Buffer} =~ /^(?:GET|HEAD) .*\r?\n\r?\n/s) {
	    # done! received complete GET or HEAD request
	    return (1);
	} elsif ($self->{Buffer} =~ /^POST .*?\nContent-Length: (\d+).*?\r?\n\r?\n(.*)/is) {
	    if (length($2) == $1) {
		# done! received all of POST Content-Length
		return (1);
	    }
	}
    } else {
#	if (not defined $nread) {
	    &throw(new W3C::Http::Proxy::ClientReadException());
#	}
	# in either case of error or eof we are done
#	return (1);
    }
    return (0);			# not done
}


sub readFromServer {
    my ($self) = @_;
    # read reply until EOF or Content-Length
    my $nread = sysread($self->{ServerSock}, $self->{Buffer}, 4096, $self->{ReadOffset});
    $self->{PROXY}->log($SELECT, "readFromServer: read $nread from $self->{ServerSock}");
    if ($nread > 0) {
	$self->{ReadOffset} += $nread;
	$self->{TotalRead} += $nread; # total read
	$self->{WriteLength} += $nread;
	if ($self->{Parallel}) {
	    #err "READ $R->{ContentType} $nread bytes from server";
	    # set up for writing what we just read from server back to client
	    $self->{PROXY}->registerWriter($self->{ClientSock});
	    $self->{PROXY}->log($SELECT, "client in WRITERS (fileno=@{[fileno($self->{ClientSock})]}, for readFromServer");
	}
	if (defined $self->{ContentLength}) {
	    if ($self->{TotalRead} == ($self->{HeaderLength} + $self->{ContentLength})) {
		return (1);
	    }
	} else {
	    if ($self->{Buffer} =~ /^(.*\nContent-Length: (\d+).*\r?\n\r?\n)/is) {
		$self->{HeaderLength} = length($1);
		$self->{ContentLength} = $2;
		$self->{PROXY}->log($PROTOCOL, "server says content-length is $self->{ContentLength}");
	    }
	}
	return (0);			# not done
    } else {
	if (defined $nread) {
	    # in either case of error or eof we are done
	    $self->{ServerEOF} = 1;
	} elsif ($! == EINTR || $! == EAGAIN || $! == EWOULDBLOCK) {
	    return (0);
	} else {
	    &throw(new W3C::Http::Proxy::ServerReadException());
	}
	return (1);
    }
}
 

sub writeToClient {
    my ($self) = @_;
    my $nwritten = syswrite($self->{ClientSock}, $self->{Buffer}, $self->{WriteLength}, $self->{WriteOffset});
    if (defined $nwritten) {
	$self->{WriteLength} -= $nwritten;
	$self->{WriteOffset} += $nwritten;
	$self->{TotalWritten} += $nwritten;
	if (!$self->{Buffering}) {
	    $self->{PROXY}->log($SELECT, "WROTE $self->{ContentType} $nwritten bytes to client");
	    # we are reading from server and writing to client in parallel
	    if ($self->{WriteLength} == 0) {
		if ($self->{ContentLength} and
		    (($self->{HeaderLength} + $self->{ContentLength}) == $self->{TotalWritten})) {
		    $self->{PROXY}->log($PROTOCOL, "Finishing due to writing total content-length $self->{ContentLength}");
		    return (1);
		}
		if ($self->{ServerEOF}) {
		    $self->{PROXY}->log($PROTOCOL, "Finishing due to server EOF");
		    return (1);
		}
		# client has drained current buffer, so re-init it
		# put next bytes from server at beginning of buffer
		$self->{WriteLength} = $self->{WriteOffset} = $self->{ReadOffset} = 0;
		# take client out of select write bits
		return (0);			# not done yet
	    }
	} else {
	    # we are writing entire content to client
	    if ($self->{WriteLength} == 0) {
		return (1);			# Done, write completed
	    }
	}
    } else {
	&throw(new W3C::Http::Proxy::ClientWriteException());
    }
}


sub writeToServer {
    my ($self) = @_;
    # send request
    my $nwritten = syswrite($self->{ServerSock}, $self->{Buffer}, $self->{WriteLength}, $self->{WriteOffset});
    if (defined $nwritten) {
	$self->{WriteLength} -= $nwritten;
	if ($self->{WriteLength} == 0) {
	    return (1);			# Done, write completed
	} else {
	    $self->{WriteOffset} += $nwritten; # more to write
	}
    } else {
	if ($! == EINTR || $! == EAGAIN || $! == EWOULDBLOCK) {
	    return (0);
	} else {
	    &throw(new W3C::Http::Proxy::ServerWriteException());
	}
    }
    return (0);			# more to write
}

# For debugging and testing.
sub blockingRequest {
    my ($self, $request) = @_;
    $self->{Buffer} = $request;
    $self->processRequest();
    $self->nonBlockingConnect();
    while (!$self->writeToServer()) {}
    while (!$self->readFromServer()) {}
    $self->setupResponseForClient();
    $self->processReply();
    return $self->{Buffer};
}

1;

__END__

=head1 NAME

W3C::Http::ProxySession - maintain state for HTTP proxies

=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

C<ProxySession> maintains proxy state for proxies derived from L<W3C::Http::Proxy>.

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
