view release on metacpan or  search on metacpan

lib/Agent/TCLI/Package/Net/HTTPD.pm  view on Meta::CPAN

package Agent::TCLI::Package::Net::HTTPD;
#
# $Id: HTTPD.pm 74 2007-06-08 00:42:53Z hacker $
#
=pod

=head1 NAME

Agent::TCLI::Package::Net::HTTPD

=head1 SYNOPSIS

From within a TCLI Agent session:

httpd uri add regex=^/good/.* response=OK200

=head1 DESCRIPTION

This module provides a package of commands for the TCLI environment. Currently
one must use the TCLI environment (or browse the source) to see documentation
for the commands it supports within the TCLI Agent.

This package starts a specialized HTTPD on the local system. It does not
return files but does return 404 or 200 values for user defined URLs. It can
also be set to completely ignore a request. URLs may be defined with
regular expressions.

It can also log directly to the log being monitored by the Tail command
in memory with no disk writes.

=head1 INTERFACE

This module must be loaded into a Agent::TCLI::Control by an
Agent::TCLI::Transport in order for a user to interface with it.

=cut

use warnings;
use strict;

use Object::InsideOut qw(Agent::TCLI::Package::Base);

use POE;
use POE::Component::Server::SimpleHTTP;
use HTTP::Request::Common qw(GET POST);
use Agent::TCLI::Command;
use Agent::TCLI::Parameter;

require FormValidator::Simple;
FormValidator::Simple->import('NetAddr::IP');

our $VERSION = '0.030.'.sprintf "%04d", (qw($Id: HTTPD.pm 74 2007-06-08 00:42:53Z hacker $))[2];

=head2 ATTRIBUTES

The following attributes are accessible through standard <attribute>
methods unless otherwise noted.

These attrbiutes are generally internal and are probably only useful to
someone trying to enhance the functionality of this Package module.

=over

=item ports

A hash of ports with HTTPD listeners running
B<ports> will only contain hash values.

=cut

my @ports			:Field
					:Type('hash')
					:Arg('name'=>'ports', 'default'=>{ } )
					:Acc('ports');

=item handlers

The array of handlers for the SimpleHTTP server.
B<handlers> will only contain Array values.

=cut
my @handlers		:Field
					:Type('Array')
					:All('handlers');

=back

=head2 METHODS

Most of these methods are for internal use within the TCLI system and may
be of interest only to developers trying to enhance TCLI.

=over

=item new ( hash of attributes )

Usually the only attributes that are useful on creation are the
verbose and do_verbose attrbiutes that are inherited from Agent::TCLI::Base.

=cut

sub _preinit :PreInit {
	my ($self,$args) = @_;

	$args->{'name'} = 'tcli_httpd';

lib/Agent/TCLI/Package/Net/HTTPD.pm  view on Meta::CPAN

=cut

sub uri {
    my ($kernel,  $self, $sender, $request, ) =
      @_[KERNEL, OBJECT,  SENDER,     ARG0, ];

	my $txt = '';
	my $code;
	my $param;
	my $command = $request->command->[0];
	my $cmd = $self->commands->{'uri_'.$command};

	return unless ( $param = $cmd->Validate($kernel, $request, $self) );

	if ( $command eq 'add' )
	{
		my $last = $self->pop_handlers;
		$self->push_handlers(
			{
				'DIR'		=>	$param->{'regex'},
				'SESSION'	=>	$self->name,
				'EVENT'		=>	$param->{'response'},
			},
			$last
		);
		$txt = 'uri added';
		$code = 200;
	}
	elsif ( $command eq 'delete' )
	{
		my $i = 0;
		$txt = "regex not found, delete failed";
		$code = 404;
		# This will loop over the handlers and removel ALL matches.
		foreach my $handler ( @{$self->handlers} )
		{
			if ( $param->{'regex'} eq $handler->{'DIR'} &&
				$i != $self->depth_handlers ) # Don't remove last one, ever.
			{
				my $goner = splice( @{$self->handlers},$i,1 );
				$txt .= "regex ".$goner->{'DIR'}." with response ".
					$goner->{'EVENT'}." deleted \n";
				$code = 200;
			}
			$i++;
		}
	}

	$request->Respond($kernel,$txt,$code);
}

=item BeGone

This POE Event handler is used as a target event for URIs. It simply drops the
connection. It will log the conenction if logging is turned on.

=cut

sub BeGone {
	# ARG0 = HTTP::Request object, ARG1 = HTTP::Response object,
	# ARG2 = the DIR that matched
	my ($kernel, $self, $request, $response, $dirmatch ) =
	  @_[KERNEL, OBJECT, ARG0 .. ARG2 ];

	my $port = $response->connection->local_port;

	# Do our stuff to HTTP::Response
	$response->code( 0 );

	$kernel->call($self->name => 'Log' => $request, $response ) if $self->logging;

	$kernel->post( 'HTTPD'.$port  , 'CLOSE', $response );
}

=item OK200

This POE Event handler is used as a target event for URIs. It will
send an HTTP response code of 200 with the content 'OK'.
It will log the conenction if logging is turned on.

=cut

sub OK200 {
	# ARG0 = HTTP::Request object, ARG1 = HTTP::Response object,
	# ARG2 = the DIR that matched
	my ($kernel, $self, $request, $response, $dirmatch ) =
	  @_[KERNEL, OBJECT,    ARG0,      ARG1,      ARG2 ];

	my $port = $response->connection->local_port;

	# Do our stuff to HTTP::Response
	$response->code( 200 );
	$response->content( 'OK' );

	$kernel->call( $self->name => 'Log' => $request, $response ) if $self->logging;

	$kernel->post('HTTPD'.$port, 'DONE', $response );
}

=item NA404

This POE Event handler is used as a target event for URIs. It will
send an HTTP response code of 404 with an error message.
It will log the conenction if logging is turned on.

=cut

sub NA404 {
	# ARG0 = HTTP::Request object, ARG1 = HTTP::Response object,
	# ARG2 = the DIR that matched
	my ($kernel, $self, $request, $response, $dirmatch ) =
	  @_[KERNEL, OBJECT, ARG0 .. ARG2 ];

	my $port = $response->connection->local_port;

	# Check for errors
	if ( ! defined $request ) {
		$_[KERNEL]->post( 'HTTPD'.$port, 'DONE', $response );
		return;
	}

	# Do our stuff to HTTP::Response
	$response->code( 404 );
	$response->content( "Hi visitor from " . $response->connection->remote_ip.
		", Page not found -> '" . $request->uri->path . "'" );

	$kernel->call($self->name => 'Log' => $request, $response ) if $self->logging;

	$kernel->post('HTTPD'.$port, 'DONE', $response );
}

=item Log

This POE Event handler is used internally to provide the logging. It sends
the time, remote ip:port, local ip:port, uri and optionally the SSL cipher
to the Tail session.

=back

=cut

sub Log {
	my ($kernel,  $self, $request, $response) =
	  @_[KERNEL, OBJECT, ARG0    , ARG1];

	$self->Verbose("Log: request(".$request->uri);
	my $port = $response->connection->local_port;

	my $log;
	# If the request was malformed, $request = undef
	if ( $request )
	{
		 $log = join (' ',
		 		time(),
		 		$response->connection->remote_ip.':'.$response->connection->remote_port,
		 		$response->connection->local_ip.':'.$port,
		 		$response->code,
		 		$request->uri,
		 		$response->connection->ssl ? $response->connection->sslcipher : '',
		 	)."\n";
	}
	else
	{
		 $log = join (' ',
		 		time(),
		 		$response->connection->remote_ip.':'.$response->connection->remote_port,
		 		$response->connection->local_ip.':'.$port,
		 		$response->code,
				'Bad request',