[Lilproxy-project] lilproxy patch Jul 4 2001

[Buggs <bug...@sp...>]

Hoi,

this patch adds logging features and HTML error messages.
We now explicitily require perl >= version 5.6.0.

You can get the new version via cvs update.

TODO:
- switch -d to enable Daemon mode (and deamon code of course)
- fork() after ->accept to avoid queuing of reqest
   see: netstat -na | grep tcp
- cooler HTML error messages ?
- more logging options


BTW, to start lilproxy with logging and custom port enter
lilproxy -p 3131 -l


Have fun,
Buggs


--- co/lilproxy/lilproxy	Wed Jul  4 00:10:22 2001
+++ wrk/lilproxy/lilproxy	Wed Jul  4 00:15:38 2001
@@ -9,6 +9,10 @@
 # perl -h
 #
 
+require v5.6.0;
+#
+# We want perl 5.6.0 or higher.
+#
 
 use HTTP::Daemon;
 use LWP::UserAgent;
@@ -29,13 +33,35 @@
 # were hard to debug.
 #
 
+use diagnostics;
+#
+# More verbosity on errors.
+#
+
+#
+# SIGNALS
+#
+
+$SIG{PIPE} = sub { print "\ngot SIGPIPE: $!\n";};
+#
+# If browser disconnects suddenly.
+#
+
+#
+# OPTIONS
+#
 
 our( %optctl, $VERSION );
 # Global variables
 
 $VERSION = 0.2;
 
-my $result = GetOptions( \%optctl => "Port=i", "help", "version" );
+my $result = GetOptions(
+						\%optctl => "Port=i",
+						"help",
+						"version",
+						"logging"
+						);
 #
 # Get command line options
 # a "," is the same as "=>"
@@ -80,7 +106,8 @@
 
 my $proxy = HTTP::Daemon->new( LocalPort => $PORT );
 #
-# Create a new HTTP::Daemon object and store a reference to it in $proxy
+# Create a new HTTP::Daemon object and
+# store a reference to it in $proxy.
 #
 
 die "@_" unless defined $proxy;
@@ -100,7 +127,8 @@
 
 my $ua = LWP::UserAgent->new;
 #
-# Create a new LWP::UserAgent object and store a reference to it in $ua
+# Create a new LWP::UserAgent object and
+# store a reference to it in $ua
 #
 
 $ua->agent("lilproxy/$VERSION");
@@ -109,12 +137,24 @@
 # You have already seen this when we create objects ( ...->new() ).
 #
 
+$ua->timeout(15);
+#
+# Default timeout from 180 to 15 seconds.
+#
+
+
+#
+# MAIN LOOP
+#
+
 while (my $conn = $proxy->accept)
 #
 # See perldoc -f while.
-# Note that the my() will make $conn lexicaly scoped to the while() block.
+# Note that the my() will make $conn lexicaly scoped
+# to the while() block.
 #
-# The call to accept() will block ( "sleep" ) until it someone connects.
+# The call to accept() will block ( "sleep" )
+# until someone connects.
 # HTTP::Daemon::ClientConn object is returned.
 # XXX not really happy with the explanation of accept() and connection.
 # Maybe we should make another small programm which explains sockets?
@@ -130,8 +170,10 @@
    	while (my $request = $conn->get_request)
 	#
 	# While the browser issues requests
-	# on this connections and does not close() the connection we loop.
-	# get_request() returns a request object containing the parsed headers.
+	# on this connections and does not close()
+	# the connection we loop.
+	# get_request() returns a request object
+	# containing the parsed headers.
 	# A reference to this object is stored in $request.
 	#
 	{
@@ -139,18 +181,49 @@
 		#
 		# We pass the request object ( actually a reference to it )
 		# to our UserAgent object's simple request method.
-		# Not much work here because the objects returned by get_request()
-		# and the objects simple_request() needs are compatible :-)
-		# The simple_request() will then fetch the requested HTML document
+		# Not much work here because the objects
+		# returned by get_request() and the objects
+		# simple_request() needs are compatible :-)
+		# The simple_request() will then fetch
+		# the requested HTML document
 		# or image or stuff. We get a response object back
 		# referenced by $response.
 		#
-		$conn->send_response($response);
+		
+		if($response->is_success or $response->is_redirect)
+		{
+			$conn->send_response($response) || print "send_response: $!\n";
+			#
+			# We pass the response object
+			# ( like always a reference actually )
+			# to the send_response method of the conn object.
+			# This sends the HTML doc or whatever
+			# back to the browser.
+			#
+			
+			log_headers($request,$response) if($optctl{logging});
+			#
+			# Log response headers.
+			#
+		}
+		else
 		#
-		# We pass the response object ( like always a reference actually )
-		# to the send_response method of the conn object.
-		# This sends the HTML doc or whatever back to the browser.
+		# Error Handling
 		#
+		{
+			my $err_response = generate_err($response);
+			#
+			# We generate a new HTTP::Response object
+			# containing our fancy error message.
+			#
+			
+			$conn->send_response($err_response);
+			#
+			# Send response back to browser.
+			#
+			
+			log_headers($request,$err_response) if($optctl{logging});
+		}
 	}
 	$conn->close;
 	#
@@ -158,3 +231,58 @@
 	# And start again with waiting for connections.
 	#
 }
+
+
+sub log_headers
+###############
+#
+# Shall log / display the headers of the traffic.
+#
+{
+	my ($request,$response) = @_;
+	# Get arguements.
+	
+	# we just print the headers
+	print	"=" x 20,"\n",
+			"URL: ",
+			"http://", $request->uri->netloc,$request->uri->path,"\n",
+			"=" x 20,
+			"\n--------------->\n",
+			$request->headers->as_string,
+			"\n<---------------\n",
+			$response->headers->as_string,"\n\n";
+}
+
+sub generate_err
+################
+#
+# Generate a HTML-formatted error message HTTP::Response object
+#
+{
+	my $response = shift;
+	my ($status_line, $code, $message) = (
+										$response->status_line,
+										$response->code,
+										$response->message
+										);
+	chomp($status_line, $code, $message);
+	my $err_mesg = <<"EOF";
+
+<html>
+<body bgcolor="#AA0000" text="darkGray" link="darkMagenta" vlink="black">
+<h1 align="center">
+$status_line
+</h1>
+</body>
+</html>
+
+
+EOF
+;
+
+	$err_mesg =~ s/\n/\015\012/g;
+	my $err_response = HTTP::Response->new( $code , $message );
+	$err_response->content($err_mesg);
+	return $err_response;
+}
+