view release on metacpan or  search on metacpan

lib/Apache2/Protocol/ESMTP.pm  view on Meta::CPAN

=head1 PROPERTIES

=head2 input_handle

Handle to read data from the client.

=head2 output_handle

Handle to write data to the client.

=head2 chunkmode

If set to true the next available data from the client
will be read in chunks of size B<chunksize>. If set to 
false data will be read a line at a time. The default
behaviour is to start in line mode, switch to chunkmode
after the message headers (EOH) and then switch back line
mode after the message body (EOM).

=head2 chunksize

Sets the size of the chunks of data read from the client
when B<chunkmode> is set to true.

=head2 disconnect

When set to true, the sever will close the client connection
when the current operation is complete. By default the client
connection will be shutdown when the QUIT operation has completed.

=cut

use base qw/Apache2::Protocol/;
use Apache2::ServerUtil ();
use Fcntl ':flock';
use base qw/Class::Accessor/;
__PACKAGE__->mk_accessors(qw//);

use POSIX 'strftime';

sub handler {
    my $c = shift;
    my $p = shift || Apache2::Protocol::ESMTP->new;

    $p->connecthandler(\&_connect);
    $p->default_line_handler(\&_unknown);
    $p->chunkhandler(\&_body);

    $p->register_callback(qr/^helo\s+(\S*?)?\s*$/i, \&_helo, 'protocol');
    $p->register_callback(qr/^ehlo\s+(\S*?)?\s*$/i, \&_ehlo, 'protocol');
    $p->register_callback(qr/^mail from:\s*<?(\S+?)?>?\s*$/i, \&_mail, 'protocol'); 
    $p->register_callback(qr/^rcpt to:\s*<?(\S+?)?>?\s*$/i, \&_rcpt, 'protocol');
    $p->register_callback(qr/^data\s*$/i, \&_data, 'protocol');
    $p->register_callback(qr/^expn\s+(\S+?)?\s*$/i, \&_expn, 'protocol');
    $p->register_callback(qr/^vrfy\s+(\S+?)?\s*$/i, \&_vrfy, 'protocol');
    $p->register_callback(qr/^rset\s*$/i, \&_rset, 'protocol');
    $p->register_callback(qr/^noop\s*$/i, \&_noop, 'protocol');
    $p->register_callback(qr/^help\s*(\S*?)?\s*$/i, \&_help, 'protocol');
    $p->register_callback(qr/^quit\s*$/i, \&_quit, 'protocol');
    $p->enable_callbacks('protocol');

    $p->setup_logging($c);

    Apache2::Protocol::handler($c, $p);
}

sub new {
    my $proto = shift;
    my $class = ref $proto || $proto;
    my $self = bless($class->SUPER::new(@_), $class);

    $self->{_bodystate}   = '';
    $self->{_headername}  = '';
    $self->{_headervalue} = '';
    $self->{_seenDATA}    = 0;
    $self->{_seenHELO}    = 0;
    $self->{_seenMAIL}    = 0;
    $self->{_seenRCPT}    = 0;

    return $self;
}

sub setup_logging {
    my $self = shift;
    my $c = shift;

    my $s = $c->base_server;

    $self->{_log_level} = $s->dir_config('ESMTPLogLevel');
    if(defined $self->{_log_level}) {
	$self->{_log_filename} = $s->dir_config('ESMTPLogFileName');
	$self->{_log_filename} = Apache2::ServerUtil::server_root . '/logs/' . $self->{_log_filename}
	    unless $self->{_log_filename} =~ m@^/@;
	$self->{_log_remotehost} = $c->get_remote_host;
    }
}

sub log_ESMTP {
    my $self = shift;
    my $level = shift;
    unless (defined $self->{_log_filename}) {
        warn "Too early for logging: " . caller;
        return;
    }
    return unless defined $self->{_log_level} && $level <= $self->{_log_level};
    my $data = shift;
    my $date = strftime('%Y-%m-%d %H:%M:%S', localtime);

    open(LOG, ">>$self->{_log_filename}") or die "Can't open log $self->{_log_filename}: $!";
    flock(LOG, LOCK_EX);
    seek(LOG, 0, 2);
    $data = "$self->{_msgid} $data" if $self->{_msgid};
    $data .= " [$self->{_log_remotehost}]" if $self->{_log_remotehost};
    print LOG "$date $data\n";
    flock(LOG, LOCK_UN);
    close(LOG);
}

sub _unknown {
    my $self = shift;
    $self->send_response($self->UNKNOWN(@_));
}

sub UNKNOWN {
    my $self = shift;
    my $line = shift;
    chomp($line);
    return(500, "Command unrecognized: $line");
}

sub _header {
    my $self = shift;
    my $line = shift;
    
    if($line =~ /^([\041-\071\073-\176.]+):\s*(.+)$/) {

        my $name  = $1;
        my $value = $2;

	if($self->{_headername} ne '') {
	    $self->HEADER($self->{_headername}, $self->{_headervalue});
	}

	$self->{_headername} = $name;
	$self->{_headervalue} = $value;

	# State management
	$self->{_seenDATA} = 1;
    }
    elsif($line =~ /^(\s+.+)$/ and $self->{_headername} ne '') {
	$self->{_headervalue} .= $1;
    }
    else {
	if($self->{_headername} ne '') {
	    $self->HEADER($self->{_headername}, $self->{_headervalue});
	    $self->{_headername} = '';
	    $self->{_headervalue} = '';
	}

	$self->_eoh($line);
    }
}

sub HEADER {
}

sub _eoh {
    my $self = shift;
    my $line = shift;

    #$self->disable_callbacks('headers');
    $self->chunkmode(1);
    $self->EOH();
    $self->_body($line);
}

sub EOH {
}

sub _body {
    my $self  = shift;
    my $chunk = shift;

    my $eom = 0;

    # Check for a message body that contains nothing except
    # the EOM sequence
    if(not $self->{_seenDATA} and $chunk =~ s/\.\r\n$/\r\n/) {
	$eom = 1;
    }
    # Now we've seen some data
    $self->{_seenDATA} = 1;

    # Prepend the bodystate so we can determine if we received a
    # segmented read of the EOM sequence
    $chunk = $self->{_bodystate} . $chunk;

    # Check for the EOM sequence 
    if($chunk =~ s/\r\n\.\r\n(.*)/\r\n/) {
	warn "Discarding extra data: $1\n" if $1;
	$eom = 1;
    }
    
    # If we haven't already found the EOM sequence then
    # search for a partial at the end of the chunk that
    # we will buffer until the next chunk comes in
    unless($eom) {
	$chunk =~ s/(\r(?:\n(?:\.(?:\r(?:\n)?)?)?)?)$//;
	$self->{_bodystate} = $1 || '';
    }

    # Send the chunk off to be processed by the subclass
    $self->BODY($chunk);

    if($eom) {
	$self->_eom();
    }
}

sub BODY {
}

sub _eom {
    my $self = shift;

    $self->chunkmode(0);
    $self->enable_callbacks('protocol');
    $self->default_line_handler(\&_unknown);

    # Clear state
    $self->{_bodystate} = '';
    $self->{_seenMAIL} = 0;
    $self->{_seenRCPT} = 0;
    $self->{_seenDATA} = 0;

    $self->send_response($self->EOM());
}

sub EOM {
    return(250, 'Message accepted for delivery');
}

#   CONNECTION ESTABLISHMENT
#      S: 220
#      E: 554
sub _connect {
    my $self = shift;
    $self->send_response($self->CONNECT(@_));
}

sub CONNECT {
    return(220, "Apache2::Protocol::ESMTP Version $VERSION");
}

#   EHLO or HELO
#      S: 250
#      E: 504, 550
sub _helo {
    my $self = shift;

    if($_[0]) {
	$self->{_seenHELO} = 1;
	$self->{_seenMAIL} = 0;
	$self->{_seenRCPT} = 0;
	$self->{_bodystate} = '';

	$self->send_response($self->HELO(@_));
    }
    else {
	$self->send_response(501, 'HELO requires domain address');
    }
    # Return OK
}

sub HELO {
    return(250, 'OK');
}

sub _ehlo {
    my $self = shift;
    
    if($_[0]) {
	$self->{_seenHELO} = 1;
	$self->{_seenMAIL} = 0;
	$self->{_seenRCPT} = 0;
	$self->{_bodystate} = '';
	

lib/Apache2/Protocol/ESMTP.pm  view on Meta::CPAN

sub _mail {
    my $self = shift;

    if($self->{_seenMAIL}) {
	$self->send_response(503, 'Sender already specified');
    }
    elsif(not $_[0]) {
	$self->send_response(501, 'MAIL requires return-path');
    }
    else {
	$self->{_seenMAIL} = 1;
	$self->send_response($self->MAIL(@_));
    }
    # Return OK
}

sub MAIL {
    my $self = shift;
    return(250, 'OK');
}

#   RCPT
#      S: 250, 251 (but see section 3.4 for discussion of 251 and 551)
#      E: 550, 551, 552, 553, 450, 451, 452, 503, 550
sub _rcpt {
    my $self = shift;

    unless($self->{_seenMAIL}) {
	$self->send_response(503, 'Need MAIL before RCPT');
    }
    elsif(not $_[0]) {
	$self->send_response(501, 'RCPT requires forward-path');
    }
    else {
	$self->{_seenRCPT} = 1;
	$self->send_response($self->RCPT(@_));
    }
    # Return OK
}

sub RCPT {
    my $self = shift;
    my $rcpt = shift;
    return(250, 'OK');
}

#   DATA
#      I: 354 -> data -> S: 250
#                        E: 552, 554, 451, 452
#      E: 451, 554, 503
sub _data {
    my $self = shift;

    if(not $self->{_seenMAIL}) {
	$self->send_response(503, 'Need MAIL command');
    }
    elsif(not $self->{_seenRCPT}) {
	$self->send_response(503, 'Need RCPT (recipient)');
    }
    else {
	$self->disable_callbacks('protocol');
	$self->default_line_handler(\&_header);
	$self->send_response($self->DATA(@_));
    }
    # Return OK
}

sub DATA {
    return(354, 'Enter mail, end with "." on a line by itself');
}

#   RSET
#      S: 250
sub _rset {
    my $self = shift;

    # Clear state
    $self->{_seenMAIL} = 0;
    $self->{_seenRCPT} = 0;
    $self->{_seenDATA} = 0;
    $self->{_bodystate} = '';

    $self->send_response($self->RSET(@_));
    # Return OK
}

sub RSET {
    return(250, 'OK');
}

#   VRFY
#      S: 250, 251, 252
#      E: 550, 551, 553, 502, 504
sub _vrfy {
    my $self = shift;
    $self->send_response($self->VRFY(@_));
    # Return OK
}

sub VRFY {
    return(252, 'Cannot VRFY user; try RCPT to attempt delivery');
}

#   EXPN
#      S: 250, 252
#      E: 550, 500, 502, 504
sub _expn {
    my $self = shift;
    $self->send_response($self->EXPN(@_));
    # Return OK
}

sub EXPN {
    return(502, 'Sorry we don\'t allow this operation');
}

#   HELP
#      S: 211, 214
#      E: 502, 504
sub _help {
    my $self = shift;