view release on metacpan or  search on metacpan

lib/AnyEvent/SMTP/Server.pm  view on Meta::CPAN

package AnyEvent::SMTP::Server;

=head1 NAME

AnyEvent::SMTP::Server - Simple asyncronous SMTP Server

=cut

use Carp;
use AnyEvent;
use common::sense;
m{# trying to cheat with cpants game ;)
use strict;
use warnings;
}x;

use base 'Object::Event';

use AnyEvent::Handle;
use AnyEvent::Socket;
use AnyEvent::Util;

use Sys::Hostname;
use Mail::Address;

use AnyEvent::SMTP::Conn;

our $VERSION = $AnyEvent::SMTP::VERSION;use AnyEvent::SMTP ();

our %CMD = map { $_ => 1 } qw( HELO EHLO MAIL RCPT QUIT DATA EXPN VRFY NOOP HELP RSET );

=head1 SYNOPSIS

    use AnyEvent::SMTP::Server 'smtp_server';

    smtp_server undef, 2525, sub {
        my $mail = shift;
        warn "Received mail from $mail->{from} to $mail->{to}\n$mail->{data}\n";
    };
    
    # or
    
    use AnyEvent::SMTP::Server;
    
    my $server = AnyEvent::SMTP::Server->new(
        port => 2525,
        mail_validate => sub {
            my ($m,$addr) = @_;
            if ($good) { return 1 } else { return 0, 513, 'Bad sender.' }
        },
        rcpt_validate => sub {
            my ($m,$addr) = @_;
            if ($good) { return 1 } else { return 0, 513, 'Bad recipient.' }
        },
        data_validate => sub {
            my ($m,$data) = @_;
            my $size = length $data;
            if ($size > $max_email_size) {
                return 0, 552, 'REJECTED: message size limit exceeded';
            } else {
                return 1;
            }
        },
    );

    $server->reg_cb(
        client => sub {
            my ($s,$con) = @_;
            warn "Client from $con->{host}:$con->{port} connected\n";
        },
        disconnect => sub {
            my ($s,$con) = @_;
            warn "Client from $con->{host}:$con->{port} gone\n";
        },
        mail => sub {
            my ($s,$mail) = @_;
            warn "Received mail from ($mail->{host}:$mail->{port}) $mail->{from} to $mail->{to}\n$mail->{data}\n";
        },
    );

    $server->start;
    AnyEvent->condvar->recv;

=head1 DESCRIPTION

Simple asyncronous SMTP server. Authorization not implemented yet. Patches are welcome

=head1 FUNCTIONS

=head2 smtp_server $host, $port, $cb->(MAIL)

=head1 METHODS

=head2 new %args;

=over 4

=item hosthame

Server FQDN

=item host

Address to listen on. by default - undef (0.0.0.0)

=item port

Port to listen on

=back

=head2 start

Creates tcp server and starts to listen

lib/AnyEvent/SMTP/Server.pm  view on Meta::CPAN

			$con = $::con;
		}
		if ($con) {
			my $msg = "500 INTERNAL ERROR";
			if ($self->{devel}) {
				$ex =~ s{(?:\r?\n)+}{ }sg;
				$ex =~ s{\s+$}{}s;
				$msg .= ": ".$ex;
			}
			$con->reply($msg);
		}
		warn "exception during $event : $ex";
	} );
	$self->reg_cb(
		command => sub {
			my ($s,$con,$com) = @_;
			my ($cmd, @args);
			for ($com) {
				s/^\s+//;s/\s+$//;
				length or last;
				($cmd, @args) = split /\s+/;
				$cmd = uc $cmd;
			}
			if (exists $CMD{$cmd}) {
				$s->handle( $con, $cmd, @args );
			} else {
				warn "$cmd @args";
				$con->reply("500 Learn to type!");
			}
			#warn "Got command @_";
		},
		HELO => sub {
			my ($s,$con,@args) = @_;
			$con->{helo} = "@args";
			$con->new_m();
			$con->ok("I'm ready.");
		},
		EHLO => sub {
			my ($s,$con,@args) = @_;
			$con->{helo} = "@args";
			$con->new_m();
			$con->ok("Go on.");
		},
		RSET => sub {
			my ($s,$con,@args) = @_;
			$con->new_m();
			$con->ok;
		},
		MAIL => sub {
			my ($s,$con,@args) = @_;
			my $from = join ' ',@args;
			$from =~ s{^from:}{}i or return $con->reply('501 Usage: MAIL FROM:<mail addr>');
			$con->{helo} or return $con->reply("503 Error: send HELO/EHLO first");
			my @addrs;
			if ($from !~ /^\s*<>\s*$/) {
				@addrs = map { $_->address } Mail::Address->parse($from);
				@addrs == 1 or return $con->reply('501 Usage: MAIL FROM:<mail addr>');
			} else {
				@addrs = ('');
			}
			if ($self->{mail_validate}) {
				my ($res,$err,$errstr) = $self->{mail_validate}->($con->{m}, $addrs[0]);
				$res or return $con->reply("$err $errstr");
			}
			$con->{m}{from} = $addrs[0];
			$con->ok;
		},
		RCPT => sub {
			my ($s,$con,@args) = @_;
			my $to = join ' ',@args;
			$to =~ s{^to:}{}i or return $con->reply('501 Usage: RCPT TO:<mail addr>');
			defined $con->{m}{from} or return $con->reply("503 Error: need MAIL command");
			my @addrs = map { $_->address } Mail::Address->parse($to);
			@addrs or return $con->reply('501 Usage: RCPT TO:<mail addr>');
			if ($self->{rcpt_validate}) {
				my ($res,$err,$errstr) = $self->{rcpt_validate}->($con->{m}, $addrs[0]);
				$res or return $con->reply("$err $errstr");
			}
			push @{ $con->{m}{to} ||= [] }, $addrs[0];
			$con->ok;
		},
		DATA => sub {
			my ($s,$con) = @_;
			defined $con->{m}{from} or return $con->reply("503 Error: need MAIL command");
			$con->{m}{to}   or return $con->reply("554 Error: need RCPT command");
			$con->reply("354 End data with <CR><LF>.<CR><LF>");
			$con->data(cb => sub {
				my $data = shift;
				if ($self->{data_validate}) {
					my ($res,$err,$errstr) = $self->{data_validate}->($con->{m}, $data);
					$res or return $con->reply("$err $errstr");
				}
				$con->{m}{data} = $data;
				local $s->{event_failed} = 0;
				local $s->{current_con} = $con;
				$s->event( mail => delete $con->{m} );
				if ($s->{event_failed}) {
					$con->reply("500 Internal Server Error");
				} else {
					$con->ok("I'll take it");
				}
			});
		},
		QUIT => sub {
			my ($s,$con,$to,@args) = @_;
			$con->reply("221 Bye.");
			$con->close;
			return;
		},
		HELP => sub { $_[1]->reply("214 No help available.") },
		NOOP => sub { $_[1]->reply("252 Ok.") },
		EXPN => sub { $_[1]->reply("252 Nice try.") },
		VRFY => sub { $_[1]->reply("252 Nice try.") },
	);
	$self;
}

sub stop {
	my $self = shift;
	for (keys %{ $self->{c} }) {
		$self->{c}{$_} and $self->{c}{$_}->close;
	}
	delete $self->{c};
	delete $self->{s};
	return;
}

sub start {
	my $self = shift;
	$self->eventcan('command') or croak "Server implementation $self doesn't parses commands";
	#$self->{engine} or croak "Server implementation $self doesn't have engine";
	$self->{s} = tcp_server $self->{host}, $self->{port}, sub {
		my ($fh,$host,$port) = @_;
		unless ($fh) {
			$self->event( error => "couldn't accept client: $!" );
			return;
		}
		$self->accept_connection(@_);
	}, sub {
		my ($sock,$host,$port) = @_;
		#$self->{sock} = $sock;
		$self->{host} = $host unless defined $self->{host};
		$self->{port} = $port unless defined $self->{port};
		warn "Server started on port $self->{port}\n" if $self->{debug};
		$self->event(ready => ());
		return undef;
	};
	
}