Net-Server-Mail-0.23/0000755000175000017500000000000012642204104013661 5ustar xavierxavierNet-Server-Mail-0.23/META.json0000644000175000017500000000215112642204104015301 0ustar xavierxavier{ "abstract" : "Class to easily create a mail server", "author" : [ "Xavier Guimard " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.0401, CPAN::Meta::Converter version 2.150005", "license" : [ "open_source" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Net-Server-Mail", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "Test::Most" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "IO::Socket::SSL" : "1.831", "Net::SMTP" : "0", "perl" : "5.008" } } }, "release_status" : "stable", "resources" : { "repository" : { "url" : "https://github.com/rs/net-server-mail" } }, "version" : "0.23", "x_serialization_backend" : "JSON::PP version 2.27300" } Net-Server-Mail-0.23/Makefile.PL0000644000175000017500000000125612605030153015637 0ustar xavierxavieruse ExtUtils::MakeMaker; use strict; use warnings; WriteMakefile( 'NAME' => 'Net::Server::Mail', 'VERSION_FROM' => 'lib/Net/Server/Mail.pm', 'PREREQ_PM' => { 'Net::SMTP' => 0, 'IO::Socket::SSL' => '1.831', }, 'BUILD_REQUIRES' => { 'Test::Most' => 0, }, ( $] >= 5.005 ? ( ABSTRACT_FROM => 'lib/Net/Server/Mail.pm', AUTHOR => 'Xavier Guimard ' ) : () ), LICENSE => 'lgpl', MIN_PERL_VERSION => '5.008', META_MERGE => { resources => { repository => 'https://github.com/rs/net-server-mail', }, }, ); Net-Server-Mail-0.23/eg/0000755000175000017500000000000012642204104014254 5ustar xavierxavierNet-Server-Mail-0.23/eg/smtp-gateway.pl0000644000175000017500000000617312642136044017251 0ustar xavierxavier#!/usr/bin/perl -w # # Olivier Poitrey # 8th november 2002 # # smtp-gateway.pl: A simple SMTP gateway example. require 5.006; use strict; use POSIX qw(setsid); use Getopt::Std; use IO::Socket; use IO::Select; use Net::Server::Mail::ESMTP; use Net::SMTP; my %opts = (p => 25, h => 'localhost', r => '', d => 0); getopts('dp:h:r:', \%opts); my $remote = $opts{r}; unless($remote) { print STDERR "Needs a remote server (-r option)\n"; exit 1; } unless($opts{d}) { # become a daemon fork and exit; setsid; } # start to listen my $server = IO::Socket::INET->new( Listen => 1, LocalPort => $opts{p}, LocalHost => $opts{h}, ) or die "can't listen $opts{h}:$opts{p}"; my $select = IO::Select->new($server); my(@ready, $fh, %session_pool); while(@ready = $select->can_read) { foreach $fh (@ready) { if($fh == $server) { my $new = $server->accept(); $new->blocking(0); my $smtpout = Net::SMTP->new( $remote, Debug => $opts{d} ) or do { $new->print("Service unavailable\n"); $new->close(); }; my $smtpin = Net::Server::Mail::ESMTP->new( socket => $new ) or die "can't start server on port $opts{p}"; $smtpin->register('Net::Server::Mail::ESMTP::PIPELINING'); $smtpin->register('Net::Server::Mail::ESMTP::8BITMIME'); $smtpin->set_callback(HELO => \&gate_helo, $smtpout); $smtpin->set_callback(MAIL => \&gate_mail, $smtpout); $smtpin->set_callback(RCPT => \&gate_rcpt, $smtpout); $smtpin->set_callback('DATA-INIT' => \&gate_datainit, $smtpout); $smtpin->set_callback('DATA-PART' => \&gate_datapart, $smtpout); $smtpin->set_callback(DATA => \&gate_dataend, $smtpout); $smtpin->set_callback(QUIT => \&gate_quit, $smtpout); $smtpin->banner(); $session_pool{$new} = $smtpin; $select->add($new); } else { my $operation = join '', <$fh>; my $rv = $session_pool{$fh}->process_once($operation); if(defined $rv) { $select->remove($fh); delete $session_pool{$fh}; $fh->close(); } } } } sub gate_helo { # Net::SMTP send HELO by himself return; } sub gate_mail { my($session, $address) = @_; my $smtpout = $session->get_context(); return $smtpout->mail($address); } sub gate_rcpt { my($session, $address) = @_; my $smtpout = $session->get_context(); return $smtpout->to($address); } sub gate_datainit { my($session) = @_; my $smtpout = $session->get_context(); return $smtpout->data(); } sub gate_datapart { my($session, $dataref) = @_; my $smtpout = $session->get_context(); return $smtpout->datasend($$dataref); } sub gate_dataend { my($session, $dataref) = @_; my $smtpout = $session->get_context(); return $smtpout->dataend(); } sub gate_quit { my($session) = @_; my $smtpout = $session->get_context(); return $smtpout->quit(); } Net-Server-Mail-0.23/eg/smtpd-select.pl0000644000175000017500000000276512642136044017236 0ustar xavierxavier#!/usr/bin/perl -w # # Olivier Poitrey # 8th november 2002 # # smtpd-select.pl: A dummy SMTP server using Net::Server::Mail and # IO::Select. require 5.006; use strict; use POSIX qw(setsid); use Getopt::Std; use IO::Socket; use IO::Select; use Net::Server::Mail::ESMTP; my %opts = (p => 25, h => 'localhost'); getopts('p:h:', \%opts); # become a daemon fork and exit; setsid; # start to listen my $server = IO::Socket::INET->new( Listen => 1, LocalPort => $opts{p}, LocalHost => $opts{h}, ) or die "can't listen $opts{h}:$opts{p}"; my $select = IO::Select->new($server); my(@ready, $fh, %session_pool); while(@ready = $select->can_read) { foreach $fh (@ready) { if($fh == $server) { my $new = $server->accept(); $select->add($new); $new->blocking(0); my $smtp = Net::Server::Mail::ESMTP->new( socket => $new ) or die "can't start server on port $opts{p}"; $smtp->register('Net::Server::Mail::ESMTP::PIPELINING'); $smtp->register('Net::Server::Mail::ESMTP::8BITMIME'); $smtp->banner(); $session_pool{$new} = $smtp; } else { my $operation = join '', <$fh>; my $rv = $session_pool{$fh}->process_once($operation); if(defined $rv) { $select->remove($fh); delete $session_pool{$fh}; $fh->close(); } } } } Net-Server-Mail-0.23/Changes0000644000175000017500000001022112642203010015143 0ustar xavierxavierRevision history for Perl extension Net::Server::Mail. 0.23 Sun Jan 3 12:29:30 2016 - Add a LICENSE file (same as COPYING). - CPANTS Kwalitee. - Fix a bug in LMTP tests (thanks to Sawyer X) 0.22 Wed Sep 9 13:41:23 2015 - Use Test::More in tests - Many spelling mistakes corrected by David Steinbrunner - Fix "LMTP server processes DATA callback multiple times" (thanks to Hatuka Nezumi). Closes: RT#106949 0.21 Thu Sep 5 12:52:56 2013 - use weak references to point to parent object in XFORWARD and PIPELING ESMTP extensions - perltidy 0.20 Thu May 14 05:50:12 2013 - Update copyright 0.19_02 Thu Mar 7 13:06:45 2013 DEV RELEASE - Merge Dan Moore and Mytram versions of STARTTLS - Include patch proposed by Georg Hoesch to reduce memory consumption 0.19 Sun Mar 3 11:52:54 2013 - Add STARTTLS extension - Fix spelling errors 0.18 Sun May 13 12:04:25 2012 - Close bug #75360 : Net::Server::Mail incorrectly processes incomplete lines during SMTP session - Close bug #71811 : Missing an email address corner case (thanks to David Darville) 0.17 Mon Mar 17 15:36:10 2008 - duplicated leading dot (RFC 2821 not correctly implemented). Closes: #34099 0.16 Tue Apr 10 22:00:06 2007 - Bug in LMTP tests - documentation update: new repository - Bug correction (closes #27154): When QUIT is sent without waiting server notification, QUIT can be found in string concatenated with body data (thanks to Raffaello Torraco, Sebastiano Piccoli & Valerio Paolini). 0.15 Sat Apr 7 15:45:56 2007 - Little bug: XFORWARD does not depend from 5.008 0.14 Mon Apr 2 7:15:45 2007 - New maintener: Xavier Guimard - Closes: #18955, #24038, #24280 / rt.cpan.org 2006-01-10 Olivier Poitrey * Release 0.14 * Removed confusing "Service ready" substring from EHLO response (reported by Stas Bekman) 2005-02-02 Olivier Poitrey * Release 0.11 * Fix an infinit loop bug introduced in 0.09 release while fixing the CPAN bug #9014 2005-01-05 Olivier Poitrey * Release 0.10 * Enable PIPELINING mode only in extended mode 2005-01-05 Olivier Poitrey * Release 0.9 * Fix CPAN bug #9014 2003-04-06 Olivier Poitrey * Release 0.8 * Platform specific patch applied for win32 to work around its lack of support for nonbocking IO. Thanks to Scotty Allen for his investigation and his patch. * Fix an RFC misunderstanding about the RSET command. Server no longer expect to HELO again after an RSET. Thanks again and again to Gerhard Zeiler. * Change the double dot handling in DATA. Thanks to Gerhard Zeiler for his patch. 2003-03-14 Olivier Poitrey * Release 0.7 * Fix a major bug in data-finished that prevent several recipients to be proceed in the LMTP module * Fix a minor bug in data-finished that prevent to reuse the session if the DATA command was failed 2003-02-06 Olivier Poitrey * Release 0.6 * Fix a major bug in data-part, at the end of data detection that prevent further command to be procced 2003-01-27 Olivier Poitrey * Release 0.5 * Fix a bug preventing compilation 2003-01-25 Olivier Poitrey * Release 0.4 * Fix a bug in constructor in handle class check * Fix a dead loop in connection handling when client close the connection before the end of transaction * Fix a bug in DATA command that prevent to detect the end of data 2003-01-01 Olivier Poitrey * Release 0.03 * Fix a bug in constructor with handle_in and handle_out * Fix a bug in POD documentation (thanks to Martin H. Sluka) * Fix a misunderstanding of the RFC, DATA command reinitialize the connection state (thanks to Martin H. Sluka) 2002-12-05 Olivier Poitrey * Release 0.02 * Fix bug in LMTP, protocol name not set * Fix bug in LMTP, data_finished() method used to use the old data handling mechanism (thanks to Andy Turner) 2002-06-20 Olivier Poitrey * Release 0.01 * Original version; created by h2xs 1.21 with options -n Net::Server::Mail -X Net-Server-Mail-0.23/t/0000755000175000017500000000000012642204104014124 5ustar xavierxavierNet-Server-Mail-0.23/t/esmtp.t0000644000175000017500000000203312642136044015446 0ustar xavierxavieruse strict; use Test::More; use IO::Socket; use Net::SMTP; plan tests => 10; use_ok('Net::Server::Mail::ESMTP'); my $server_port = 2525; my $server; while ( not defined $server && $server_port < 4000 ) { $server = IO::Socket::INET->new( Listen => 1, LocalPort => ++$server_port, ); } my $pid = fork; if ( !$pid ) { while ( my $conn = $server->accept ) { my $m = Net::Server::Mail::ESMTP->new( socket => $conn, idle_timeout => 5 ) or die "can't start server on port $server_port"; $m->register('Net::Server::Mail::ESMTP::PIPELINING'); $m->register('Net::Server::Mail::ESMTP::XFORWARD'); $m->process; } } my $smtp = new Net::SMTP "localhost:$server_port", Debug => 0; ok( defined $smtp ); ok( $smtp->mail("test\@bla.com") ); ok( !$smtp->mail("test\@bla.com") ); ok( $smtp->to('postmaster') ); ok( $smtp->to('postmaster') ); ok( $smtp->data ); ok( $smtp->datasend('To: postmaster') ); ok( $smtp->dataend ); ok( $smtp->quit ); kill 1, $pid; wait; Net-Server-Mail-0.23/t/lmtp.t0000644000175000017500000000244412642136424015302 0ustar xavierxavieruse strict; use Test::More; use IO::Socket; plan tests => 10; eval('use Net::LMTP'); SKIP: { if ($@) { skip( "You don't seem to have Net::LMTP installed on your system", 10 ); } else{ use_ok('Net::Server::Mail::LMTP'); my $server_port = 2525; my $server; while ( not defined $server && $server_port < 4000 ) { $server = IO::Socket::INET->new( Listen => 1, LocalPort => ++$server_port, ); } my $pid = fork; if ( !$pid ) { while ( my $conn = $server->accept ) { my $m = Net::Server::Mail::LMTP->new( socket => $conn, idle_timeout => 5 ) or die "can't start server on port 2525"; $m->set_callback( 'DATA', sub { return $_[1] !~ /bad/ } ); $m->process; } SKIP: { skip( 'This is the son', 10 ); } } my $lmtp = Net::LMTP->new( 'localhost', $server_port, Debug => 0 ); ok( defined $lmtp ); ok( $lmtp->mail("test\@bla.com") ); ok( !$lmtp->mail("test\@bla.com") ); ok( $lmtp->to('bad') ); ok( $lmtp->to('postmaster') ); ok( $lmtp->data ); ok( $lmtp->datasend('To: postmaster') ); ok( $lmtp->dataend ); ok( $lmtp->quit ); kill 1, $pid; wait; } } Net-Server-Mail-0.23/t/starttls.t0000644000175000017500000002275412642136044016212 0ustar xavierxavier# Copyright (C) 2013 - Mytram # Copyright (C) 2013 - Xavier Guimard # This program is free software; you can redistribute it and/or modify it # under the terms of either: the GNU General Public License as published # by the Free Software Foundation; or the Artistic License. # # See http://dev.perl.org/licenses/ for more information. use IO::Socket::INET; use Net::Server::Mail::ESMTP; use Net::Server::Mail::ESMTP::STARTTLS; use IO::Socket::SSL qw(1.831 SSL_VERIFY_NONE); use Net::SMTP; use Net::Cmd; use Test::Most; use constant { OK => 250, DEFER => 450, NORETRY => 250, # Drop the message silently so that it doesn't bounce }; use strict; use warnings; my ( @tests, @socks ); my $host = '127.0.0.1'; my $port = 20000 + int( rand(1000) ); my $sender = 'sender@example.com'; my $recip1 = 'recip1@example.com'; my $recip2 = 'recip2@example.com'; my $data = << "EOS"; Subject: test message From: <$sender> To: <$recip1> To: <$recip2> hello world. EOS push @tests, [ 'STARTTLS support', sub { my $s = Net::SMTP->new( $host, Port => $port, Hello => 'localhost' ); $s->peerhost eq $host or die "peerport is not $host"; $s->peerport eq $port or die "peerport is not $port"; defined $s->supports( 'STARTTLS', 500, ["'STARTTLS' is not supported"] ) or die "starttls is not supported"; $s->command("STARTTLS")->response == Net::Cmd::CMD_OK or die "Cannot start command"; # cause the server to close the connetion $s->command("hello"); $s->command("bye"); $s->quit; return 1; }, {} ]; push @tests, [ 'STARTTLS invalid parameters', sub { my $s = Net::SMTP->new( $host, Port => $port, Hello => 'localhost' ); $s->peerhost eq $host or die "peerport is not $host"; $s->peerport eq $port or die "peerport is not $port"; defined $s->supports( 'STARTTLS', 500, ["'STARTTLS' is not supported"] ) or die "starttls is not supported"; $s->command("STARTTLS HELLO WORLD")->response == Net::Cmd::CMD_ERROR or die "Invalid paramter accepted"; $s->quit; return 1; }, {} ]; push @tests, [ 'STARTTLS handshake', sub { my $s = Net::SMTP->new( $host, Port => $port, Hello => 'localhost' ); $s->peerhost eq $host or die "peerport is not $host"; $s->peerport eq $port or die "peerport is not $port"; defined $s->supports( 'STARTTLS', 500, ["'STARTTLS' is not supported"] ) or die "starttls is not supported"; $s->command("STARTTLS")->response == Net::Cmd::CMD_OK or die "Cannot start command"; my $rv = IO::Socket::SSL->start_SSL( $s, SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_NONE, ); ( defined $rv && ref $rv eq 'IO::Socket::SSL' ) or die "TLS handshake failed " . IO::Socket::SSL::errstr(); $s->close; return 1; }, {} ]; push @tests, [ 'STARTTLS handshake failed in SSL_VERIFY_PEER', sub { my $s = Net::SMTP->new( $host, Port => $port, Hello => 'localhost' ); $s->peerhost eq $host or die "peerport is not $host"; $s->peerport eq $port or die "peerport is not $port"; defined $s->supports( 'STARTTLS', 500, ["'STARTTLS' is not supported"] ) or die "starttls is not supported"; $s->command("STARTTLS")->response == Net::Cmd::CMD_OK or die "Cannot start command"; my $rv = IO::Socket::SSL->start_SSL( $s, SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_PEER, ); !( defined $rv && ref $rv eq 'IO::Socket::SSL' ) or die "TLS handeshake failed"; $s->close; return 1; }, {} ]; push @tests, [ 'SMTP Plain', sub { my $s = Net::SMTP->new( $host, Port => $port, Hello => 'localhost' ); $s->peerhost eq $host or die "peerport is not $host"; $s->peerport eq $port or die "peerport is not $port"; $s->mail($sender); $s->to( $recip1, $recip2 ); $s->data(); $s->datasend($data); $s->dataend(); $s->quit; return 1; }, { DATA => sub { # processing my ( $session, $message ) = @_; my $s = $session->get_sender(); ok( $s eq $sender, "Sender" ); my @recipients = $session->get_recipients(); my %recips = map { $_ => 1 } @recipients; ok( $recips{$recip1}, "found $recip1" ); ok( $recips{$recip2}, "found $recip2" ); ok( $$message, "found message" ); return ( 1, OK, 'Success!' ); } } ]; sub upgrade_to_tls { my $s = shift; defined $s->supports( 'STARTTLS', 500, ["'STARTTLS' is not supported"] ) or die "starttls is not supported"; $s->command("STARTTLS")->response == Net::Cmd::CMD_OK or die "Cannot start command"; my $rv = IO::Socket::SSL->start_SSL( $s, { SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_NONE } ) or die "Cannot upgrade to tls"; # $s is IO::Socket::SSL now Net::Cmd::command( $s, 'EHLO localhost' ) or die "Cannot send EHLO localhost command"; Net::Cmd::response($s) == Net::Cmd::CMD_OK or die "EHLO failed after upgrading to TLS"; } push @tests, [ 'TLS and quit', sub { my $s = _Net::SMTPS->new( $host, Port => $port, Hello => 'localhost' ); unless ( defined $s ) { return 1; } $s->quit; return 1; }, { # No server verification } ]; push @tests, [ 'TLS and send message', sub { my $s = _Net::SMTPS->new( $host, Port => $port ); unless ( defined $s ) { return 1; } $s->mail($sender); $s->to( $recip1, $recip2 ); $s->data(); $s->datasend($data); $s->dataend(); $s->quit; return 1; }, { DATA => sub { # processing my ( $session, $message ) = @_; my $s = $session->get_sender(); ok( $s eq $sender, "Sender" ); my @recipients = $session->get_recipients(); my %recips = map { $_ => 1 } @recipients; ok( $recips{$recip1}, "found $recip1" ); ok( $recips{$recip2}, "found $recip2" ); ok( $$message, "found message" ); return ( 1, OK, 'Success!' ); } } ]; sub process_test { my $sock = shift; my $tc_id = shift; my $test = shift; my $client = $sock->accept; push @socks, $client; my $smtp = Net::Server::Mail::ESMTP->new( socket => $client, idle_timeout => 300, SSL_config => { SSL_cert_file => 't/certs/server-cert.pem', SSL_key_file => 't/certs/server-key.pem', }, ) or die "Cannot create ESMTP"; ok( $smtp, "Accepted client for $tc_id: " . $test->[0] ); $smtp->register('Net::Server::Mail::ESMTP::STARTTLS'); $smtp->set_callback( DATA => $test->[2]{DATA} || sub { } ); $smtp->process(); $client->close; shift @socks; } my $ppid = $$; my $pid = fork(); if ( !defined $pid ) { die $!; } elsif ($pid) { # child process - server my $sock = IO::Socket::INET->new( Listen => 1, LocalAddr => $host, LocalPort => $port, Proto => 'tcp', Timeout => 5, ); if ( !$sock ) { kill 9, $pid; diag("kill 9 $pid (child)"); plan skip_all => "Cannot create sock: $!"; exit; } push @socks, $sock; my $id = 0; for (@tests) { $id++; my $tc = sprintf( "Test%02d", $id ); process_test( $sock, $tc, $_ ); } wait; $sock->close; done_testing(); exit; } else { # child sleep 1; # to give server time to set up sock for my $test (@tests) { my $rv; eval { local $SIG{__DIE__}; $rv = $test->[1]->(); }; if ( $@ || !$rv ) { # kill the server diag("Error: $@"); diag("kill 9, $ppid (server)"); kill 9, $ppid; exit; } } exit; } BEGIN { package _Net::SMTPS; use strict; use warnings; use IO::Socket::SSL; use Net::Cmd; use Sys::Hostname; our @ISA = qw(IO::Socket::SSL Net::SMTP); sub new { my $class = shift; my $host = shift; my %args = @_; my $s = Net::SMTP->new( $host, %args ); if ( defined $s->supports( 'STARTTLS', 500, ["Command unknown: 'STARTTLS'"] ) ) { # OK, TLS is advertised as supported. Let's try it. if ( $s->command('STARTTLS')->response == CMD_OK ) { # The STARTTLS command was accepted, now begin SSL negotiation. # Net::SMTP::TLS is hardcoded! This will break # future inheritance my $rv = _Net::SMTPS->start_SSL( $s, SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_NONE, %args, ); # $self has been blessed to $class return undef unless ref $rv; $s->hello( $args{Hello} || Sys::Hostname::hostname ); return $s; } } return undef; } 1; } END { $_->close for @socks; } Net-Server-Mail-0.23/t/smtp.t0000644000175000017500000000163312642136044015306 0ustar xavierxavieruse strict; use Test::More; use IO::Socket; use Net::SMTP; plan tests => 10; use_ok('Net::Server::Mail::SMTP'); my $server_port = 2525; my $server; while ( not defined $server && $server_port < 4000 ) { $server = IO::Socket::INET->new( Listen => 1, LocalPort => ++$server_port, ); } my $pid = fork; if ( !$pid ) { while ( my $conn = $server->accept ) { my $m = Net::Server::Mail::SMTP->new( socket => $conn, idle_timeout => 5 ) or die "can't start server on port 2525"; $m->process; } } my $smtp = Net::SMTP->new( "localhost:$server_port", Debug => 0 ); ok( defined $smtp ); ok( $smtp->mail("test\@bla.com") ); ok( !$smtp->mail("test\@bla.com") ); ok( $smtp->to('postmaster') ); ok( $smtp->to('postmaster') ); ok( $smtp->data ); ok( $smtp->datasend('To: postmaster') ); ok( $smtp->dataend ); ok( $smtp->quit ); kill 1, $pid; wait; Net-Server-Mail-0.23/t/certs/0000755000175000017500000000000012642204104015244 5ustar xavierxavierNet-Server-Mail-0.23/t/certs/server-key.pem0000644000175000017500000000156712605030153020054 0ustar xavierxavier-----BEGIN RSA PRIVATE KEY----- MIICXQIBAAKBgQCfmHNLNKpPwlo8PbrwVFXm1Yqgj+SUWnJHNJphUMzQgY03xI4M ebTk2Q1xBj0HTSr/tWrv2zbwvu2ysC4Yr/M1knEVhPUqyxi9ftsmGMFOMSoBuBvJ qd9sYnQgSU1RFJP01hgH8z3Z99wQM+QAomxisFl+X/mOtqWvrfb75vrfmwIDAQAB AoGBAJmJZ7m9U+/hkUANPzAAYpftbi1j4Urb7L8WG0NuIWyihgJVxTa5S88yBZ1r nADPO4O/u74/Tg60ECdtGRvFAhtNwQA1DWIqoVat9kaFsXaJDRqalSFVNyJL94C8 NEDNkBOfL0LNDfbLdekHrsEx16Sk4Cb3+GwPcQlCBj83Oft5AkEA0QXrySU0/+yb 2M30SOe5m9h5G42RQHJ5wFz7e3NwN9iFd6rIcYAKaJ2vNjN67fYV8TqdCncOL2+2 ZjkeHIeWpQJBAMN2uh1ma0JRGHBG0zK5IiL5C0tvajoF+cNAgOfl7vf1CtRx5KW9 x2aOZumfzm9t0NbcutmEjGB0XbZdCNg9CT8CQEbUetHuiccvpqARKnaKD5t//4oW ruHn6NoGqDFtLNm/xXqHpOTRPrW0uWrkhwOcIFNeSVkCfwwUDvsU399LEwECQQCc GpIBMO6wg/u0j5vUgq6Up7kxgcWgmW0jVrycd7ImLXl8uYkWJT6+1TOzmYFQ1K9Z KefAGG/UCJtfLWYG7JgZAkBNooGdD0taYFyfAlxgbjVqNpgubgnpXvh3G4SRbm3J itE3l4HvYIrLPQVBzG2fomU+AIH8T9NleyFQNRB0BZay -----END RSA PRIVATE KEY----- Net-Server-Mail-0.23/t/certs/server-cert.pem0000644000175000017500000000701512605030153020213 0ustar xavierxavierCertificate: Data: Version: 3 (0x2) Serial Number: d6:d7:e1:b4:b3:30:91:f0 Signature Algorithm: sha1WithRSAEncryption Issuer: C=DE, ST=Bayern, L=Muenchen, O=Whatever it is, CN=IO::Socket::SSL Demo CA Validity Not Before: Jan 1 00:00:01 2008 GMT Not After : Mar 30 07:05:44 2019 GMT Subject: C=DE, ST=Bayern, L=Muenchen, O=Whatever it is, CN=server.local Subject Public Key Info: Public Key Algorithm: rsaEncryption RSA Public Key: (1024 bit) Modulus (1024 bit): 00:9f:98:73:4b:34:aa:4f:c2:5a:3c:3d:ba:f0:54: 55:e6:d5:8a:a0:8f:e4:94:5a:72:47:34:9a:61:50: cc:d0:81:8d:37:c4:8e:0c:79:b4:e4:d9:0d:71:06: 3d:07:4d:2a:ff:b5:6a:ef:db:36:f0:be:ed:b2:b0: 2e:18:af:f3:35:92:71:15:84:f5:2a:cb:18:bd:7e: db:26:18:c1:4e:31:2a:01:b8:1b:c9:a9:df:6c:62: 74:20:49:4d:51:14:93:f4:d6:18:07:f3:3d:d9:f7: dc:10:33:e4:00:a2:6c:62:b0:59:7e:5f:f9:8e:b6: a5:af:ad:f6:fb:e6:fa:df:9b Exponent: 65537 (0x10001) X509v3 extensions: X509v3 Basic Constraints: CA:FALSE Netscape Comment: OpenSSL Generated Certificate X509v3 Subject Key Identifier: BC:81:38:7B:62:C9:DD:A9:BA:5E:9C:44:AA:AE:71:39:7A:81:C9:E8 X509v3 Authority Key Identifier: keyid:DE:65:01:16:19:2E:51:E0:9A:51:1A:37:50:94:7D:39:29:2A:42:2C DirName:/C=DE/ST=Bayern/L=Muenchen/O=Whatever it is/CN=IO::Socket::SSL Demo CA serial:E7:AD:8B:07:55:8A:17:27 X509v3 Key Usage: Digital Signature, Non Repudiation, Key Encipherment Signature Algorithm: sha1WithRSAEncryption 22:ac:b3:a0:67:eb:c2:40:36:9a:56:71:20:fc:2e:4b:3d:db: b1:83:f3:96:5a:33:9b:db:33:de:52:dc:9c:80:36:78:9b:e3: 90:ea:63:cc:0c:ac:0f:bd:01:20:26:8f:47:27:83:23:a9:90: b6:ae:5c:d8:3c:20:27:ca:04:b4:5e:9b:85:fc:34:af:5e:91: 60:3b:d2:df:b7:06:ae:e3:01:09:1f:89:af:0a:18:0a:3f:ef: 43:d6:3d:6e:16:74:32:b3:06:f0:8a:f4:80:61:f7:f1:83:85: e8:2c:1d:b8:83:f6:81:87:b3:cd:2b:0b:88:1a:f9:3f:15:77: 3b:cc -----BEGIN CERTIFICATE----- MIIDVzCCAsCgAwIBAgIJANbX4bSzMJHwMA0GCSqGSIb3DQEBBQUAMGwxCzAJBgNV BAYTAkRFMQ8wDQYDVQQIEwZCYXllcm4xETAPBgNVBAcTCE11ZW5jaGVuMRcwFQYD VQQKEw5XaGF0ZXZlciBpdCBpczEgMB4GA1UEAxMXSU86OlNvY2tldDo6U1NMIERl bW8gQ0EwHhcNMDgwMTAxMDAwMDAxWhcNMTkwMzMwMDcwNTQ0WjBhMQswCQYDVQQG EwJERTEPMA0GA1UECBMGQmF5ZXJuMREwDwYDVQQHEwhNdWVuY2hlbjEXMBUGA1UE ChMOV2hhdGV2ZXIgaXQgaXMxFTATBgNVBAMTDHNlcnZlci5sb2NhbDCBnzANBgkq hkiG9w0BAQEFAAOBjQAwgYkCgYEAn5hzSzSqT8JaPD268FRV5tWKoI/klFpyRzSa YVDM0IGNN8SODHm05NkNcQY9B00q/7Vq79s28L7tsrAuGK/zNZJxFYT1KssYvX7b JhjBTjEqAbgbyanfbGJ0IElNURST9NYYB/M92ffcEDPkAKJsYrBZfl/5jralr632 ++b635sCAwEAAaOCAQowggEGMAkGA1UdEwQCMAAwLAYJYIZIAYb4QgENBB8WHU9w ZW5TU0wgR2VuZXJhdGVkIENlcnRpZmljYXRlMB0GA1UdDgQWBBS8gTh7Ysndqbpe nESqrnE5eoHJ6DCBngYDVR0jBIGWMIGTgBTeZQEWGS5R4JpRGjdQlH05KSpCLKFw pG4wbDELMAkGA1UEBhMCREUxDzANBgNVBAgTBkJheWVybjERMA8GA1UEBxMITXVl bmNoZW4xFzAVBgNVBAoTDldoYXRldmVyIGl0IGlzMSAwHgYDVQQDExdJTzo6U29j a2V0OjpTU0wgRGVtbyBDQYIJAOetiwdVihcnMAsGA1UdDwQEAwIF4DANBgkqhkiG 9w0BAQUFAAOBgQAirLOgZ+vCQDaaVnEg/C5LPduxg/OWWjOb2zPeUtycgDZ4m+OQ 6mPMDKwPvQEgJo9HJ4MjqZC2rlzYPCAnygS0XpuF/DSvXpFgO9Lftwau4wEJH4mv ChgKP+9D1j1uFnQyswbwivSAYffxg4XoLB24g/aBh7PNKwuIGvk/FXc7zA== -----END CERTIFICATE----- Net-Server-Mail-0.23/MANIFEST0000644000175000017500000000113112642204104015006 0ustar xavierxavierChanges COPYING eg/smtp-gateway.pl eg/smtpd-select.pl lib/Net/Server/Mail.pm lib/Net/Server/Mail/ESMTP.pm lib/Net/Server/Mail/ESMTP/8BITMIME.pm lib/Net/Server/Mail/ESMTP/Extension.pm lib/Net/Server/Mail/ESMTP/PIPELINING.pm lib/Net/Server/Mail/ESMTP/STARTTLS.pm lib/Net/Server/Mail/ESMTP/XFORWARD.pm lib/Net/Server/Mail/LMTP.pm lib/Net/Server/Mail/SMTP.pm LICENSE Makefile.PL MANIFEST This list of files META.yml README.md t/certs/server-cert.pem t/certs/server-key.pem t/esmtp.t t/lmtp.t t/smtp.t t/starttls.t TODO META.json Module JSON meta-data (added by MakeMaker) Net-Server-Mail-0.23/TODO0000644000175000017500000000011712605030153014350 0ustar xavierxavierNet::Server::Mail TODO ---------------------- TODO list for Net::Server::Mail Net-Server-Mail-0.23/README.md0000644000175000017500000000411412605031666015152 0ustar xavierxavierNet::Server::Mail ================= This module is a versatile and extensible implementation of the SMTP protocol and its different evolutions like ESMTP and LMTP. The event driven object-oriented API makes easy to incorporate the SMTP protocol to your programs. Other SMTPd implementations don't support useful ESMTP extensions and the LMTP protocol. Their interface design precludes adding them later. So I've decided to rewrite a complete implementation with extensibility in mind. It provides mechanism to easy addition future or not yet implemented ESMTP extensions. Developers can hook code at each SMTP session state and change the module's behaviors by registering event call-backs. The class is designed to be easily inherited from. Installation ------------ To install this module type the following: perl Makefile.PL make make test make install Dependencies ------------ This module requires these other modules and libraries: Sys::Hostname IO::Select and Carp all available on CPAN. Licence ------- This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Copyright --------- * Copyright (C) 2002 - Olivier Poitrey * Copyright (C) 2007-2015 - Xavier Guimard STARTTLS * Copyright (C) 2009 - Dan Moore * Copyright (C) 2013 - Mytram * Copyright (C) 2013 - Xavier Guimard Contributors * Georg Hoesch (patch to reduce memory consumption) Net-Server-Mail-0.23/LICENSE0000644000175000017500000000537112642203157014703 0ustar xavierxavierFormat: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/ Upstream-Name: lemonldap-ng Upstream-Contact: Xavier Guimard Source: https://metacpan.org/release/Net-Server-Mail Files: * Copyright: 2002, Olivier Poitrey 2007-2016, Xavier Guimard License: LGPL-2.1+ Files: lib/Net/Server/Mail/ESMTP/STARTTLS.pm t/starttls.t Copyright: 2013, Mytram License: Artistic-2 License: Artistic-2 This program is free software; you can redistribute it and/or modify it under the terms of the the Artistic License (2.0). You may obtain a copy of the full license at: http://www.perlfoundation.org/artistic_license_2_0 . Any use, modification, and distribution of the Standard or Modified Versions is governed by this Artistic License. By using, modifying or distributing the Package, you accept this license. Do not use, modify, or distribute the Package, if you do not accept this license. . If your Modified Version has been derived from a Modified Version made by someone other than you, you are nevertheless required to ensure that your Modified Version complies with the requirements of this license. . This license does not grant you the right to use any trademark, service mark, tradename, or logo of the Copyright Holder. . This license includes the non-exclusive, worldwide, free-of-charge patent license to make, have made, use, offer to sell, sell, import and otherwise transfer the Package with respect to any patent claims licensable by the Copyright Holder that are necessarily infringed by the Package. If you institute patent litigation (including a cross-claim or counterclaim) against any party alleging that the Package constitutes direct or contributory patent infringement, then this Artistic License to you shall terminate on the date that such litigation is filed. . Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. License: LGPL-2.1+ This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1, or (at your option) any later version. . The complete text of version 1 of the GNU General Public License can be found in http://opensource.org/licenses/LGPL-2.1 Net-Server-Mail-0.23/COPYING0000644000175000017500000000537112642203172014726 0ustar xavierxavierFormat: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/ Upstream-Name: lemonldap-ng Upstream-Contact: Xavier Guimard Source: https://metacpan.org/release/Net-Server-Mail Files: * Copyright: 2002, Olivier Poitrey 2007-2016, Xavier Guimard License: LGPL-2.1+ Files: lib/Net/Server/Mail/ESMTP/STARTTLS.pm t/starttls.t Copyright: 2013, Mytram License: Artistic-2 License: Artistic-2 This program is free software; you can redistribute it and/or modify it under the terms of the the Artistic License (2.0). You may obtain a copy of the full license at: http://www.perlfoundation.org/artistic_license_2_0 . Any use, modification, and distribution of the Standard or Modified Versions is governed by this Artistic License. By using, modifying or distributing the Package, you accept this license. Do not use, modify, or distribute the Package, if you do not accept this license. . If your Modified Version has been derived from a Modified Version made by someone other than you, you are nevertheless required to ensure that your Modified Version complies with the requirements of this license. . This license does not grant you the right to use any trademark, service mark, tradename, or logo of the Copyright Holder. . This license includes the non-exclusive, worldwide, free-of-charge patent license to make, have made, use, offer to sell, sell, import and otherwise transfer the Package with respect to any patent claims licensable by the Copyright Holder that are necessarily infringed by the Package. If you institute patent litigation (including a cross-claim or counterclaim) against any party alleging that the Package constitutes direct or contributory patent infringement, then this Artistic License to you shall terminate on the date that such litigation is filed. . Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. License: LGPL-2.1+ This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1, or (at your option) any later version. . The complete text of version 1 of the GNU General Public License can be found in http://opensource.org/licenses/LGPL-2.1 Net-Server-Mail-0.23/lib/0000755000175000017500000000000012642204104014427 5ustar xavierxavierNet-Server-Mail-0.23/lib/Net/0000755000175000017500000000000012642204104015155 5ustar xavierxavierNet-Server-Mail-0.23/lib/Net/Server/0000755000175000017500000000000012642204104016423 5ustar xavierxavierNet-Server-Mail-0.23/lib/Net/Server/Mail/0000755000175000017500000000000012642204104017305 5ustar xavierxavierNet-Server-Mail-0.23/lib/Net/Server/Mail/ESMTP/0000755000175000017500000000000012642204104020175 5ustar xavierxavierNet-Server-Mail-0.23/lib/Net/Server/Mail/ESMTP/STARTTLS.pm0000644000175000017500000001114012642203604022014 0ustar xavierxavier# # Copyright 2013 Mytram . All rights reserved. # # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # package Net::Server::Mail::ESMTP::STARTTLS; use 5.006; use strict; use warnings; # IO::Socket::SSL v1.831 fixed a readline() behavioural deviation in # list context on nonblocking sockets, which caused Net::Server::Mail # to fail to read commands correctly use IO::Socket::SSL 1.831; use Net::Server::Mail::ESMTP::Extension; our @ISA = qw(Net::Server::Mail::ESMTP::Extension); our $VERSION = 0.23; use constant { REPLY_READY_TO_START => 220, REPLY_SYNTAX_ERROR => 502, REPLY_NOT_AVAILABLE => 454, }; # https://tools.ietf.org/html/rfc2487 sub verb { my $self = shift; return ( [ 'STARTTLS' => \&starttls ] ); } sub keyword { 'STARTTLS' } # Return a non undef to signal the server to close the socket. sub starttls { my $server = shift; my $args = shift; if ($args) { # No parameter verb $server->reply( REPLY_SYNTAX_ERROR, 'Syntax error (no parameters allowed)' ); return; } my $ssl_config = $server->{options}{ssl_config} if exists $server->{options}{ssl_config}; if ( !$ssl_config || ref $ssl_config ne 'HASH' ) { $server->reply( REPLY_NOT_AVAILABLE, 'TLS not available due to temporary reason' ); return; } $server->reply( REPLY_READY_TO_START, 'Ready to start TLS' ); my $ssl_socket = IO::Socket::SSL->start_SSL( $server->{options}{socket}, %$ssl_config, SSL_server => 1, ); # Use SSL_startHandshake to control nonblocking behaviour # See perldoc IO::Socket::SSL for more if ( !$ssl_socket || !$ssl_socket->isa('IO::Socket::SSL') ) { $server->reply( REPLY_NOT_AVAILABLE, 'TLS not available due to temporary reason [' . IO::Socket::SSL::errstr() . ']' ); return 0; # to single the server to close the socket } my $ref = $server->{callback}->{STARTTLS}; if ( defined $ref && ref $ref eq 'ARRAY' && ref $ref->[0] eq 'CODE' ) { my $code = $ref->[0]; &$code($server); } return (); } 1; =head1 NAME Net::Server::Mail::ESMTP::STARTTLS - A module to support the STARTTLS command in Net::Server::Mail::ESMTP =head1 SYNOPSIS use strict; use Net::Server::Mail::ESMTP; my @local_domains = qw(example.com example.org); my $server = IO::Socket::INET->new( Listen => 1, LocalPort => 25 ); my $conn; while($conn = $server->accept) { my $esmtp = Net::Server::Mail::ESMTP->new( socket => $conn, SSL_config => { SSL_cert_file => 'your_cert.pem', SSL_key_file => 'your_key.key', # Any other options taken by IO::Socket::SSL } ); # activate some extensions $esmtp->register('Net::Server::Mail::ESMTP::STARTTLS'); # adding optional STARTTLS handler $esmtp->set_callback(STARTTLS => \&tls_started); $esmtp->process(); $conn->close(); } sub tls_started { my ($session) = @_; # Now, allow authentication $session->register('Net::Server::Mail::ESMTP::AUTH'); } =head1 DESCRIPTION This module conducts a TLS handshake with the client upon receiving the STARTTLS command. It uses IO::Socket::SSL, requiring 1.831+, to perform the handshake and secure traffic. An additional option, SSL_config, is passed to Net::Server::Mail::ESMTP's constructor. It contains options for IO::Socket::SSL's constructor. Please refer to IO::Socket::SSL's perldoc for details. =head1 SEE ALSO Please, see L =head1 AUTHOR This module has been written by Xavier Guimard using libs written by: =over =item Mytram =item Dan Moore C<< >> =back =head1 AVAILABILITY Available on CPAN. anonymous Git repository: git clone git://github.com/rs/net-server-mail.git Git repository on the web: L =head1 BUGS Please use CPAN system to report a bug (http://rt.cpan.org/). =head1 LICENSE AND COPYRIGHT =over =item Copyright (C) 2009 - Dan Moore =item Copyright (C) 2013 - Mytram =item Copyright (C) 2013 - Xavier Guimard =back This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See http://dev.perl.org/licenses/ for more information. =cut Net-Server-Mail-0.23/lib/Net/Server/Mail/ESMTP/XFORWARD.pm0000644000175000017500000001344512642203620022000 0ustar xavierxavierpackage Net::Server::Mail::ESMTP::XFORWARD; use 5.006; use strict; use warnings; use Scalar::Util qw(weaken); our $VERSION = '0.23'; use base qw(Net::Server::Mail::ESMTP::Extension); sub init { my ( $self, $parent ) = @_; $self->{parent} = $parent; weaken( $self->{parent} ); return $self; } sub verb { my $self = shift; return [ 'XFORWARD' => 'xforward' ]; } sub keyword { return 'XFORWARD'; } sub parameter { my $self = shift; return "NAME ADDR PROTO HELO SOURCE"; } sub xforward { my $self = shift; my $args = shift; my %h = ( $args =~ /(NAME|ADDR|PROTO|HELO|SOURCE)=([^\s]+)\s*/g ); $args =~ s/(?:NAME|ADDR|PROTO|HELO|SOURCE)=[^\s]+\s*//g; if ( $args !~ /^\s*$/ ) { $args =~ s/=.*$//; $self->reply( 501, "5.5.4 Bad XFORWARD attribute name: $args" ); } else { $self->{"xforward"}->{ lc($_) } = $h{$_} foreach ( keys %h ); $self->make_event( name => 'XFORWARD', arguments => [ $self->{"xforward"} ], on_success => sub { #my $buffer = $self->step_forward_path(); #$buffer = [] unless ref $buffer eq 'ARRAY'; #push(@$buffer, $address); #$self->step_forward_path($buffer); #$self->step_maildata_path(1); }, success_reply => [ 250, "OK" ], failure_reply => [ 550, 'Failure' ], ); } return; } sub get_forwarded_values { my $self = shift; return $self->{xforward}; } sub get_forwarded_name { my $self = shift; return $self->{xforward}->{name}; } sub get_forwarded_address { my $self = shift; return $self->{xforward}->{addr}; } sub get_forwarded_proto { my $self = shift; return $self->{xforward}->{proto}; } sub get_forwarded_helo { my $self = shift; return $self->{xforward}->{helo}; } sub get_forwarded_source { my $self = shift; return $self->{xforward}->{source}; } # New subroutines in Net::Server::Mail::ESMTP space *Net::Server::Mail::ESMTP::xforward = \&xforward; *Net::Server::Mail::ESMTP::get_forwarded_values = \&get_forwarded_values; *Net::Server::Mail::ESMTP::get_forwarded_name = \&get_forwarded_name; *Net::Server::Mail::ESMTP::get_forwarded_address = \&get_forwarded_address; *Net::Server::Mail::ESMTP::get_forwarded_proto = \&get_forwarded_proto; *Net::Server::Mail::ESMTP::get_forwarded_helo = \&get_forwarded_helo; *Net::Server::Mail::ESMTP::get_forwarded_source = \&get_forwarded_source; 1; __END__ =head1 NAME Net::Server::Mail::ESMTP::XFORWARD - A module to add support to the XFORWARD command in Net::Server::Mail::ESMTP =head1 SYNOPSIS use Net::Server::Mail::ESMTP; my @local_domains = qw(example.com example.org); my $server = IO::Socket::INET->new( Listen => 1, LocalPort => 25 ); my $conn; while($conn = $server->accept) { my $esmtp = Net::Server::Mail::ESMTP->new( socket => $conn ); # activate XFORWARD extension if remote client is localhost $esmtp->register('Net::Server::Mail::ESMTP::XFORWARD') if($server->get_property('peeraddr') =~ /^127/); # adding some handlers $esmtp->set_callback(RCPT => \&validate_recipient); # adding XFORWARD handler $esmtp->set_callback(XFORWARD => \&xforward); $esmtp->process(); $conn->close(); } sub xforward { my $self = shift; # Reject non IPV4 addresses return 0 unless( $self->get_forwarded_address =~ /^\d+\.\d+\.\d+\.\d+$/ ); 1; } sub validate_recipient { my($session, $recipient) = @_; my $domain; if($recipient =~ /@(.*)>\s*$/) { $domain = $1; } if(not defined $domain) { return(0, 513, 'Syntax error.'); } elsif(not(grep $domain eq $_, @local_domains) && $session->get_forwarded_addr != "10.1.1.1") { return(0, 554, "$recipient: Recipient address rejected: Relay access denied"); } return(1); } =head1 DESCRIPTION When using a Net::Server::Mail::ESMTP script inside a MTA and not in front of Internet, values like client IP address are not accessible to the script and when the script returns mail to another instance of smtpd daemon, it logs "localhost" as incoming address. To solve this problem, some administrators use the XFORWARD command. This module gives the ability to read and store XFORWARD information. =head2 METHODS These methods return the values set by the upstream MTA without modifying them so they can be set to undef or "[UNVAILABLE]". See Postfix documentation for more. =over =item * get_forwarded_values : returns a hash reference containing all values forwarded (keys in lower case). =item * get_forwarded_name : returns the up-stream hostname. The hostname may be a non-DNS hostname. =item * get_forwarded_address : returns the up-stream network address. Address information is not enclosed with []. The address may be a non-IP address. =item * get_forwarded_source : returns LOCAL or REMOTE. =item * get_forwarded_helo : returns the hostname that the up-stream host announced itself. It may be a non-DNS hostname. =item * get_forwarded_proto : returns the mail protocol for receiving mail from the up-stream host. This may be an SMTP or non-SMTP protocol name of up to 64 characters. =back =head1 SEE ALSO L, L =head1 AUTHOR Xavier Guimard, Ex.guimard@free.frE =head1 COPYRIGHT AND LICENSE Copyright (C) 2006 by Xavier Guimard This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.6.4 or, at your option, any later version of Perl 5 you may have available. Net-Server-Mail-0.23/lib/Net/Server/Mail/ESMTP/Extension.pm0000644000175000017500000000166312642203553022524 0ustar xavierxavierpackage Net::Server::Mail::ESMTP::Extension; use 5.006; use strict; use warnings; our $VERSION = "0.23"; =pod =head1 NAME Net::Server::Mail::ESMTP::Extension - The base class for ESMTP extension system =head1 DESCRIPTION =cut sub new { my ( $proto, $parent ) = @_; my $class = ref $proto || $proto; my $self = {}; bless( $self, $class ); return $self->init($parent); } =pod =head1 init ($self) = $obj->init($parent); You can override this method to do something at the initialisation. The method takes the $smtp object as parameter. =cut sub init { my ( $self, $parent ) = @_; return $self; } =pod =head1 verb =cut sub verb { return (); } =pod =head1 keyword =cut sub keyword { return 'XNOTOVERLOADED'; } =pod =head1 parameter =cut sub parameter { return (); } =pod =head1 option =cut sub option { return (); } =pod =head1 reply =cut sub reply { return (); } 1; Net-Server-Mail-0.23/lib/Net/Server/Mail/ESMTP/PIPELINING.pm0000644000175000017500000000463312642203570022205 0ustar xavierxavierpackage Net::Server::Mail::ESMTP::PIPELINING; use 5.006; use strict; use warnings; use base 'Net::Server::Mail::ESMTP::Extension'; use constant GROUP_COMMANDS => [qw(RSET MAIL SEND SOML SAML RCPT)]; use Scalar::Util qw(weaken); our $VERSION = 0.23; sub init { my ( $self, $parent ) = @_; $self->{parent} = $parent; weaken( $self->{parent} ); return $self; } sub extend_mode { my ( $self, $mode ) = @_; if ($mode) { $self->{old_process_operation} = $self->{parent}->{process_operation}; $self->{parent}->{process_operation} = \&process_operation; $self->{old_handle_more} = $self->{parent}->{data_handle_more_data}; $self->{parent}->{data_handle_more_data} = 1; } else { if ( exists( $self->{old_process_operation} ) ) { $self->{parent}->{process_operation} = $self->{old_process_operation}; } if ( exists( $self->{old_handle_more} ) ) { $self->{parent}->{data_handle_more_data} = $self->{old_handle_more}; } } } sub process_operation { my ( $self, $operation ) = @_; my @commands = grep( length $_, split( /\r?\n/, $operation ) ); for ( my $i = 0 ; $i <= $#commands ; $i++ ) { my ( $verb, $params ) = $self->tokenize_command( $commands[$i] ); # Once the client SMTP has confirmed that support exists for # the pipelining extension, the client SMTP may then elect to # transmit groups of SMTP commands in batches without waiting # for a response to each individual command. In particular, # the commands RSET, MAIL FROM, SEND FROM, SOML FROM, SAML # FROM, and RCPT TO can all appear anywhere in a pipelined # command group. The EHLO, DATA, VRFY, EXPN, TURN, QUIT, and # NOOP commands can only appear as the last command in a group # since their success or failure produces a change of state # which the client SMTP must accommodate. (NOOP is included in # this group so it can be used as a synchronization point.) if ( $i < $#commands && not grep( $verb eq $_, @{ (GROUP_COMMANDS) } ) ) { $self->reply( 550, "Protocol error: `$verb' not allowed in a group of commands" ); return; } my $rv = $self->process_command( $verb, $params ); return $rv if defined $rv; } return; } sub keyword { return 'PIPELINING'; } 1; Net-Server-Mail-0.23/lib/Net/Server/Mail/ESMTP/8BITMIME.pm0000644000175000017500000000046612642203536021727 0ustar xavierxavierpackage Net::Server::Mail::ESMTP::8BITMIME; use 5.006; use strict; use warnings; use base qw(Net::Server::Mail::ESMTP::Extension); our $VERSION = "0.23"; sub keyword { return '8BITMIME'; } sub option { return ( [ 'MAIL', BODY => \&option_mail_body ], ); } sub option_mail_body { return; } 1; Net-Server-Mail-0.23/lib/Net/Server/Mail/LMTP.pm0000644000175000017500000001404212642203634020427 0ustar xavierxavierpackage Net::Server::Mail::LMTP; use 5.006; use strict; use base qw(Net::Server::Mail::ESMTP); our $VERSION = "0.23"; =pod =head1 NAME Net::Server::Mail::LMTP - A module to implement the LMTP protocol =head1 SYNOPSIS use Net::Server::Mail::LMTP; my @local_domains = qw(example.com example.org); my $server = IO::Socket::INET->new( Listen => 1, LocalPort => 25 ); my $conn; while($conn = $server->accept) { my $esmtp = Net::Server::Mail::LMTP->new( socket => $conn ); # adding some handlers $esmtp->set_callback(RCPT => \&validate_recipient); $esmtp->set_callback(DATA => \&queue_message); $esmtp->process(); $conn->close(); } sub validate_recipient { my($session, $recipient) = @_; my $domain; if($recipient =~ /@(.*)>\s*$/) { $domain = $1; } if(not defined $domain) { return(0, 513, 'Syntax error.'); } elsif(not(grep $domain eq $_, @local_domains)) { return(0, 554, "$recipient: Recipient address rejected: Relay access denied"); } return(1); } sub queue_message { my($session, $data) = @_; my $sender = $session->get_sender(); my @recipients = $session->get_recipients(); return(0, 554, 'Error: no valid recipients') unless(@recipients); my $msgid = add_queue($sender, \@recipients, $data) or return(0); return(1, 250, "message queued $msgid"); } =head1 DESCRIPTION This class implement the LMTP (RFC 2033) protocol. This class inherit from Net::Server::Mail::ESMTP. Please see L for documentation of common methods. =cut sub init { my ( $self, @args ) = @_; my $rv = $self->SUPER::init(@args); return $rv unless $rv eq $self; $self->undef_verb('HELO'); $self->undef_verb('EHLO'); $self->def_verb( LHLO => 'lhlo' ); # Required by RFC $self->register('Net::Server::Mail::ESMTP::PIPELINING'); return $self; } sub get_protoname { return 'LMTP'; } =pod =head1 EVENTS Descriptions of callback who's can be used with set_callback method. All handle takes the Net::Server::Mail::ESMTP object as first argument and specific callback's arguments. =head2 LHLO Same as ESMTP EHLO, please see L. =cut sub lhlo { my ( $self, $hostname ) = @_; unless ( defined $hostname && length $hostname ) { $self->reply( 501, 'Syntax error in parameters or arguments' ); return; } my $response = $self->get_hostname . ' Service ready'; my @extends; foreach my $extend ( $self->get_extensions ) { push( @extends, join( ' ', $extend->keyword, $extend->parameter ) ); } $self->extend_mode(1); $self->make_event( name => 'LHLO', arguments => [ $hostname, \@extends ], on_success => sub { # according to the RFC, LHLO ensures "that both the SMTP client # and the SMTP server are in the initial state" $self->{extend_mode} = 1; $self->step_reverse_path(1); $self->step_forward_path(0); $self->step_maildata_path(0); }, success_reply => [ 250, [ $response, @extends ] ], ); return; } =pod =head2 DATA Overide the default DATA event by a per recipient response. It will be called for each recipients with data (in a scalar reference) as first argument followed by the current recipient. =cut sub data { my ( $self, $args ) = @_; unless ( ref $self->step_forward_path eq 'ARRAY' and @{ $self->step_forward_path } ) { $self->reply( 503, 'Bad sequence of commands' ); return; } $self->SUPER::data($args); } sub data_finished { my ( $self, $more_data ) = @_; my @recipients = @{ $self->step_forward_path || [] }; $self->{continuous_reply} = 1; while ( my $forward_path = shift @recipients ) { $self->{continuous_reply} = 0 unless @recipients; $self->make_event( name => 'DATA', arguments => [ \$self->{_data}, $forward_path ], success_reply => [ 250, 'Ok' ], failure_reply => [ 550, "$forward_path Failed" ], ); } $self->{continuous_reply} = 0; # reinitiate the connection $self->step_reverse_path(1); $self->step_forward_path(0); $self->step_maildata_path(0); # if more data, handle it if ($more_data) { return $self->{process_operation}( $self, $more_data ); } else { return; } } sub reply { my ( $self, $code, $msg ) = @_; if ( not ref $msg and $self->{continuous_reply} ) { my $out = $self->{out}; print $out "$code-$msg\r\n"; } else { $self->SUPER::reply( $code, $msg ); } } =pod =head1 SEE ALSO Please, see L, L and L. =head1 AUTHOR Olivier Poitrey Ers@rhapsodyk.netE =head1 AVAILABILITY Available on CPAN. anonymous Git repository: git clone git://github.com/rs/net-server-mail.git Git repository on the web: L =head1 BUGS Please use CPAN system to report a bug (http://rt.cpan.org/). =head1 LICENCE This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA =head1 COPYRIGHT Copyright (C) 2002 - Olivier Poitrey, 2007 - Xavier Guimard =cut 1; Net-Server-Mail-0.23/lib/Net/Server/Mail/ESMTP.pm0000644000175000017500000001772212642203513020547 0ustar xavierxavierpackage Net::Server::Mail::ESMTP; use 5.006; use strict; use warnings; use Carp; use base qw(Net::Server::Mail::SMTP); our $VERSION = "0.23"; =pod =head1 NAME Net::Server::Mail::ESMTP - A module to implement the ESMTP protocol =head1 SYNOPSIS use Net::Server::Mail::ESMTP; my @local_domains = qw(example.com example.org); my $server = IO::Socket::INET->new( Listen => 1, LocalPort => 25 ); my $conn; while($conn = $server->accept) { my $esmtp = Net::Server::Mail::ESMTP->new( socket => $conn ); # activate some extensions $esmtp->register('Net::Server::Mail::ESMTP::8BITMIME'); $esmtp->register('Net::Server::Mail::ESMTP::PIPELINING'); # adding some handlers $esmtp->set_callback(RCPT => \&validate_recipient); $esmtp->set_callback(DATA => \&queue_message); $esmtp->process(); $conn->close(); } sub validate_recipient { my($session, $recipient) = @_; my $domain; if($recipient =~ /@(.*)>\s*$/) { $domain = $1; } if(not defined $domain) { return(0, 513, 'Syntax error.'); } elsif(not(grep $domain eq $_, @local_domains)) { return(0, 554, "$recipient: Recipient address rejected: Relay access denied"); } return(1); } sub queue_message { my($session, $data) = @_; my $sender = $session->get_sender(); my @recipients = $session->get_recipients(); return(0, 554, 'Error: no valid recipients') unless(@recipients); my $msgid = add_queue($sender, \@recipients, $data) or return(0); return(1, 250, "message queued $msgid"); } =head1 DESCRIPTION This class implement the ESMTP (RFC 2821) protocol. This class inherit from Net::Server::Mail::SMTP. Please see L for documentation of common methods. =head1 METHODS ESMTP specific methods. =cut sub init { my ( $self, @args ) = @_; my $rv = $self->SUPER::init(@args); return $rv unless $rv eq $self; $self->def_verb( EHLO => 'ehlo' ); $self->{extend_mode} = 0; return $self; } sub get_protoname { return 'ESMTP'; } sub get_extensions { my ($self) = @_; return ( @{ $self->{extensions} || [] } ); } =pod =head2 register Activate an ESMTP extension. This method takes a module's name as argument. This module must implement certain methods. See L for more details. =cut sub register { my ( $self, $class ) = @_; # try to import class eval "require $class" or croak("can't register module `$class'"); # test mandatory methods foreach my $method (qw(new verb keyword parameter option reply)) { confess( "Extension class `$class' doesn't implement mandatory method `$method'" ) unless ( $class->can($method) ); } my $extend = $class->new($self) or return; foreach my $verb_def ( $extend->verb ) { $self->def_verb(@$verb_def) or return; } foreach my $option_def ( $extend->option ) { $self->sub_option(@$option_def); } foreach my $reply_def ( $extend->reply ) { $self->sub_reply(@$reply_def); } push( @{ $self->{extensions} }, $extend ); return 1; } sub sub_option { my ( $self, $verb, $option_key, $code ) = @_; confess("can't subscribe to option for verb `$verb'") unless ( $verb eq 'MAIL' or $verb eq 'RCPT' ); confess("allready subscribed `$option_key'") if ( exists $self->{xoption}->{$verb}->{$option_key} ); $self->{xoption}->{$verb}->{$option_key} = $code; } sub sub_reply { my ( $self, $verb, $code ) = @_; confess("trying to subscribe to an unsupported verb `$verb'") unless ( grep( $verb eq $_, $self->list_verb ) ); push( @{ $self->{xreply}->{$verb} }, $code ); } sub extend_mode { my ( $self, $mode ) = @_; $self->{extend_mode} = $mode; for my $extend ( @{ $self->{extensions} } ) { if ( $extend->can('extend_mode') ) { $extend->extend_mode($mode); } } } =pod =head1 EVENTS Descriptions of callback who's can be used with set_callback method. All handle takes the Net::Server::Mail::ESMTP object as first argument and specific callback's arguments. =head2 EHLO Takes the hostname given as argument. Engage the reverse path step on success. RFC 2821 requires that EHLO command return the list of supported extension. Default success reply implement this, so it is deprecated to override this reply. You can rebuild extension list with get_extensions() method. Exemple: my @extends; foreach my $extend ($esmtp->get_extensions()) { push(@extends, join(' ', $extend->keyword(), $extend->parameter())); } my $extends_string = join("\n", @extends); =cut sub ehlo { my ( $self, $hostname ) = @_; unless ( defined $hostname && length $hostname ) { $self->reply( 501, 'Syntax error in parameters or arguments' ); return; } my $response = $self->get_hostname . ' Service ready'; my @extends; foreach my $extend ( $self->get_extensions ) { push( @extends, join( ' ', $extend->keyword, $extend->parameter ) ); } $self->extend_mode(1); $self->make_event( name => 'EHLO', arguments => [ $hostname, \@extends ], on_success => sub { # according to the RFC, EHLO ensures "that both the SMTP client # and the SMTP server are in the initial state" $self->step_reverse_path(1); $self->step_forward_path(0); $self->step_maildata_path(0); }, success_reply => [ 250, [ $response, @extends ] ], ); return; } sub helo { my ( $self, $hostname ) = @_; $self->{extend_mode} = 0; $self->SUPER::helo($hostname); } sub handle_options { my ( $self, $verb, $address, @options ) = @_; if ( @options && !$self->{extend_mode} ) { $self->reply( 555, "Unsupported option: $options[0]" ); return 0; } for ( my $i = $#options ; $i >= 0 ; $i-- ) { my ( $key, $value ) = split( /=/, $options[$i], 2 ); my $handler = $self->{xoption}->{$verb}->{$key}; if ( defined $handler ) { no strict "refs"; &$handler( $self, $verb, $address, $key, $value ); } else { $self->reply( 555, "Unsupported option: $key" ); return 0; } } return 1; } sub handle_reply { my ( $self, $verb, $success, $code, $msg ) = @_; if ( $self->{extend_mode} && exists $self->{xreply}->{$verb} ) { foreach my $handler ( @{ $self->{xreply}->{$verb} } ) { ( $code, $msg ) = &$handler( $self, $verb, $success, $code, $msg ); } } $self->reply( $code, $msg ); } =pod =head1 SEE ALSO Please, see L, L and L. =head1 AUTHOR Olivier Poitrey Ers@rhapsodyk.netE =head1 AVAILABILITY Available on CPAN. anonymous Git repository: git clone git://github.com/rs/net-server-mail.git Git repository on the web: L =head1 BUGS Please use CPAN system to report a bug (http://rt.cpan.org/). =head1 LICENCE This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA =head1 COPYRIGHT Copyright (C) 2002 - Olivier Poitrey, 2007 - Xavier Guimard =cut 1; Net-Server-Mail-0.23/lib/Net/Server/Mail/SMTP.pm0000644000175000017500000003710212642203647020444 0ustar xavierxavierpackage Net::Server::Mail::SMTP; use 5.006; use strict; use base 'Net::Server::Mail'; our $VERSION = "0.23"; =pod =head1 NAME Net::Server::Mail::SMTP - A module to implement the SMTP protocol =head1 SYNOPSIS use Net::Server::Mail::SMTP; my @local_domains = qw(example.com example.org); my $server = IO::Socket::INET->new( Listen => 1, LocalPort => 25 ); my $conn; while($conn = $server->accept) { my $smtp = Net::Server::Mail::SMTP->new( socket => $conn ); $smtp->set_callback(RCPT => \&validate_recipient); $smtp->set_callback(DATA => \&queue_message); $smtp->process(); $conn->close(); } sub validate_recipient { my($session, $recipient) = @_; my $domain; if($recipient =~ /@(.*)>\s*$/) { $domain = $1; } if(not defined $domain) { return(0, 513, 'Syntax error.'); } elsif(not(grep $domain eq $_, @local_domains)) { return(0, 554, "$recipient: Recipient address rejected: Relay access denied"); } return(1); } sub queue_message { my($session, $data) = @_; my $sender = $session->get_sender(); my @recipients = $session->get_recipients(); return(0, 554, 'Error: no valid recipients') unless(@recipients); my $msgid = add_queue($sender, \@recipients, $data) or return(0); return(1, 250, "message queued $msgid"); } =head1 DESCRIPTION This class implement the SMTP (RFC 821) protocol. Notice that it don't implement the extension mechanism introduce in RFC 2821. You have to use Net::Server::Mail::ESMTP if you want this capability. This class inherit from Net::Server::Mail. Please see L for documentation of common methods. =head1 METHODS SMTP specific methods. =cut sub init { my ( $self, @args ) = @_; my $rv = $self->SUPER::init(@args); return $rv unless $rv eq $self; $self->def_verb( HELO => 'helo' ); $self->def_verb( VRFY => 'vrfy' ); $self->def_verb( EXPN => 'expn' ); $self->def_verb( TURN => 'turn' ); $self->def_verb( HELP => 'help' ); $self->def_verb( NOOP => 'noop' ); $self->def_verb( MAIL => 'mail' ); $self->def_verb( RCPT => 'rcpt' ); $self->def_verb( SEND => 'send' ); $self->def_verb( SOML => 'soml' ); $self->def_verb( SAML => 'saml' ); $self->def_verb( DATA => 'data' ); $self->def_verb( RSET => 'rset' ); $self->def_verb( QUIT => 'quit' ); # go to the initial step $self->step_reverse_path(0); $self->step_forward_path(0); $self->step_maildata_path(0); # handle data after the end of data indicator (.) $self->{data_handle_more_data} = 0; return $self; } sub step_reverse_path { my ( $self, $bool ) = @_; if ( defined $bool ) { $self->{reverse_path} = $bool; } return $self->{reverse_path}; } sub step_forward_path { my ( $self, $bool ) = @_; if ( defined $bool ) { $self->{forward_path} = $bool; } return $self->{forward_path}; } sub step_maildata_path { my ( $self, $bool ) = @_; if ( defined $bool ) { $self->{maildata_path} = $bool; # initialise data container if ( not $bool ) { $self->{_data} = ''; } } return $self->{maildata_path}; } sub get_protoname { return 'SMTP'; } =pod =head2 get_sender Returns the sender of the current session. Return undefined if the reverse path step is not complete. =cut sub get_sender { my ($self) = @_; my $sender = $self->step_reverse_path(); return ( $sender ? $sender : undef ); } =pod =head2 get_recipients Returns the list of recipients supplied by client. Returns undef if forward_path step is not engaged. Returns an empty list if not recipients succeed. =cut sub get_recipients { my ($self) = @_; my $recipients = $self->step_forward_path(); return ( ref $recipients ? @$recipients : undef ); } =pod =head1 EVENTS Descriptions of callback who's can be used with set_callback method. All handle takes the Net::Server::Mail::SMTP object as first argument and specific callback's arguments. =head2 HELO Takes the hostname given as argument. Engage the reverse path step on success. sub helo_handle { my($session, $hostname) = @_; if($hostname eq 'localhost') { return(0, 553, q(I don't like this hostname, try again.)); } # don't forgot to return a success reply if you are happy with # command's value return 1; } =cut sub helo { my ( $self, $hostname ) = @_; unless ( defined $hostname && length $hostname ) { $self->reply( 501, 'Syntax error in parameters or arguments' ); return; } $self->make_event( name => 'HELO', arguments => [$hostname], on_success => sub { # according to the RFC, HELO ensures "that both the SMTP client # and the SMTP server are in the initial state" $self->step_reverse_path(1); $self->step_forward_path(0); $self->step_maildata_path(0); }, success_reply => [ 250, 'Requested mail action okay, completed' ], ); return; } =pod =head2 NOOP This handler takes no argument =cut sub noop { my ($self) = @_; $self->make_event( name => 'NOOP' ); return; } =pod =head2 EXPN Command not yet implemented. Handler takes address as argument. =cut sub expn { my ( $self, $address ) = @_; $self->make_event( name => 'EXPN', arguments => [$address], default_reply => [ 502, 'Command not implemented' ] ); return; } =pod =head2 EXPN Command not implemented, deprecated by RFC 2821 Handler takes no argument. =cut sub turn { # deprecated in RFC 2821 my ($self) = @_; $self->reply( 502, 'Command not implemented' ); $self->make_event( name => 'TURN', default_reply => [ 502, 'Command not implemented' ] ); return; } =pod =head2 VRFY Command not yet implemented. Handler takes address as argument. =cut sub vrfy { my ( $self, $address ) = @_; $self->make_event( name => 'VRFY', arguments => [$address], default_reply => [ 502, 'Command not implemented' ] ); return; } =pod =head2 HELP Command not yet implemented. Handler takes a command name as argument. =cut sub help { my ( $self, $command ) = @_; $self->make_event( name => 'HELP', arguments => [$command], default_reply => [ 502, 'Command not implemented' ] ); return; } =pod =head2 MAIL Handler takes address as argument. On success, engage the forward path step and keep the given address for later use (get it with get_sender() method). =cut sub mail { my ( $self, $args ) = @_; unless ( $self->step_reverse_path ) { $self->reply( 503, 'Bad sequence of commands' ); return; } unless ( $args =~ s/^from:\s*//i ) { $self->reply( 501, 'Syntax error in parameters or arguments' ); return; } if ( $self->step_forward_path ) { $self->reply( 503, 'Bad sequence of commands' ); return; } my ( $address, $rest, @options ); unless ( ( $address, $rest ) = $args =~ /^<(.*?)>(?: (\S.*))?$/ ) { $self->reply( 501, 'Syntax error in parameters or arguments' ); return; } if ($rest) { @options = split ' ', $rest; } unless ( $self->handle_options( 'MAIL', $address, @options ) ) { return; } $self->make_event( name => 'MAIL', arguments => [$address], on_success => sub { $self->step_reverse_path($address); $self->step_forward_path(1); }, success_reply => [ 250, "sender $address OK" ], failure_reply => [ 550, 'Failure' ], ); return; } =pod =head2 RCPT Handler takes address as argument. On success, engage the mail data path step and push the given address into the recipient list for later use (get it with get_recipients() method). =cut sub rcpt { my ( $self, $args ) = @_; unless ( $self->step_forward_path ) { $self->reply( 503, 'Bad sequence of commands' ); return; } unless ( $args =~ s/^to:\s*//i ) { $self->reply( 501, 'Syntax error in parameters or arguments' ); return; } my ( $address, $rest, @options ); unless ( ( $address, $rest ) = $args =~ /^<(.*?)>(?: (\S.*))?$/ ) { $self->reply( 501, 'Syntax error in parameters or arguments' ); return; } if ($rest) { @options = split ' ', $rest; } unless ( $self->handle_options( 'RCPT', $address, @options ) ) { return; } $self->make_event( name => 'RCPT', arguments => [$address], on_success => sub { my $buffer = $self->step_forward_path(); $buffer = [] unless ref $buffer eq 'ARRAY'; push( @$buffer, $address ); $self->step_forward_path($buffer); $self->step_maildata_path(1); }, success_reply => [ 250, "recipient $address OK" ], failure_reply => [ 550, 'Failure' ], ); return; } =pod =head2 SEND Command not implemented. Handler takes no argument. =cut # we overwrite a perl command... we shouldn't need it in this class, # but take care. sub send { my ($self) = @_; $self->make_event( name => 'SEND', default_reply => [ 502, 'Command not implemented' ] ); return; } =pod =head2 SOML Command not implemented. Handler takes no argument. =cut sub soml { my ($self) = @_; $self->make_event( name => 'SOML', default_reply => [ 502, 'Command not implemented' ] ); return; } =pod =head2 SAML Command not implemented. Handler takes no argument. =cut sub saml { my ($self) = @_; $self->make_event( name => 'SAML', default_reply => [ 502, 'Command not implemented' ] ); return; } =pod =head2 DATA This handler is called after the final . sent by client. It takes data as argument in a scalar reference. You should queue the message and reply with the queue ID. =head2 DATA-INIT This handler is called before enter in the "waiting for data" step. The default success reply is a 354 code telling the client to send the mail content. =head2 DATA-PART This handler is called at each parts of mail content sent. It takes as argument a scalar reference to the part of data received. It is deprecated to change the contents of this scalar. =cut sub data { my ( $self, $args ) = @_; unless ( $self->step_maildata_path ) { $self->reply( 503, 'Bad sequence of commands' ); return; } if ( defined $args && length $args ) { $self->reply( 501, 'Syntax error in parameters or arguments' ); return; } $self->{last_chunk} = ''; $self->make_event( name => 'DATA-INIT', on_success => sub { $self->next_input_to( \&data_part ); }, success_reply => [ 354, 'Start mail input; end with .' ] ); return; } # Because data is cut into pieces (4096 bytes), we have to search # "\r\n.\r\n" sequence in 2 consecutive pieces. $self->{last_chunk} # contains the last 5 bytes. sub data_part { my ( $self, $data ) = @_; # search for end of data indicator $data ||= ''; if ( "$self->{last_chunk}$data" =~ /\r?\n\.\r?\n/s ) { my $more_data = $'; if ( length $more_data ) { # Client sent a command after the end of data indicator ".". if ( !$self->{data_handle_more_data} ) { $self->reply( 453, "Command received prior to completion of" . " previous command sequence" ); return; } } # RFC 821 compliance. ( $data = "$self->{last_chunk}$data" ) =~ s/(\r?\n)\.\r?\n(QUIT\r?\n)?$/$1/s; $self->{_data} .= $data; # RFC 2821 by the letter $self->{_data} =~ s/^\.(.+\015\012)(?!\n)/$1/gm; return $self->data_finished($more_data); } my $tmp = $self->{last_chunk}; $self->{last_chunk} = substr $data, -5; $data = $tmp . ( $data ? substr( $data, 0, -5 ) : '' ); $self->make_event( name => 'DATA-PART', arguments => [ \$data ], on_success => sub { $self->{_data} .= $data; # please, recall me soon ! $self->next_input_to( \&data_part ); }, success_reply => '', # don't send any reply ! ); return; } sub data_finished { my ( $self, $more_data ) = @_; $self->make_event( name => 'DATA', arguments => [ \$self->{_data} ], success_reply => [ 250, 'message sent' ], ); # reinitiate the connection $self->step_reverse_path(1); $self->step_forward_path(0); $self->step_maildata_path(0); # if more data, handle it if ($more_data) { return $self->{process_operation}( $self, $more_data ); } else { return; } } =pod =head2 RSET Handler takes no argument. On success, all step are initialized and sender/recipients list are flushed. =cut sub rset { my ($self) = @_; $self->make_event( name => 'RSET', on_success => sub { $self->step_reverse_path(1) if ( $self->step_reverse_path() ); $self->step_forward_path(0); $self->step_maildata_path(0); }, success_reply => [ 250, 'Requested mail action okay, completed' ], ); return; } =pod =head2 QUIT Handler takes no argument. Connection is closed after this command. This behavior may change in future, you will probably be able to control the closing of connection. =cut sub quit { my ($self) = @_; $self->make_event( name => 'QUIT', success_reply => [ 221, $self->get_hostname . ' Service closing transmission channel' ], ); return 1; # close cnx } ########################################################################## sub handle_options { # handle options for verb MAIL and RCPT my ( $self, $verb, $address, @options ) = @_; if (@options) { $self->reply( 555, "Unsupported option: $options[0]" ); return 0; } return 1; } =pod =head1 SEE ALSO Please, see L, L and L. =head1 AUTHOR Olivier Poitrey Ers@rhapsodyk.netE =head1 AVAILABILITY Available on CPAN. anonymous Git repository: git clone git://github.com/rs/net-server-mail.git Git repository on the web: L =head1 BUGS Please use CPAN system to report a bug (http://rt.cpan.org/). =head1 LICENCE This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA =head1 COPYRIGHT Copyright (C) 2002 - Olivier Poitrey, 2007 - Xavier Guimard =cut 1; Net-Server-Mail-0.23/lib/Net/Server/Mail.pm0000644000175000017500000004532012642203362017654 0ustar xavierxavierpackage Net::Server::Mail; use 5.006; use strict; use warnings; use Sys::Hostname; use IO::Select; use IO::Handle; use Carp; use constant HOSTNAME => hostname(); $Net::Server::Mail::VERSION = '0.23'; =pod =head1 NAME Net::Server::Mail - Class to easily create a mail server =head1 SYNOPSIS use Net::Server::Mail::SMTP; my @local_domains = qw(example.com example.org); my $server = IO::Socket::INET->new( Listen => 1, LocalPort => 25 ); my $conn; while($conn = $server->accept) { my $smtp = Net::Server::Mail::SMTP->new( socket => $conn ); $smtp->set_callback(RCPT => \&validate_recipient); $smtp->set_callback(DATA => \&queue_message); $smtp->process(); $conn->close(); } sub validate_recipient { my($session, $recipient) = @_; my $domain; if($recipient =~ /@(.*)>\s*$/) { $domain = $1; } if(not defined $domain) { return(0, 513, 'Syntax error.'); } elsif(not(grep $domain eq $_, @local_domains)) { return(0, 554, "$recipient: Recipient address rejected: Relay access denied"); } return(1); } sub queue_message { my($session, $data) = @_; my $sender = $session->get_sender(); my @recipients = $session->get_recipients(); return(0, 554, 'Error: no valid recipients') unless(@recipients); my $msgid = add_queue($sender, \@recipients, $data); or return(0); return(1, 250, "message queued $msgid"); } =head1 DESCRIPTION This module is a versatile and extensible implementation of the SMTP protocol and its different evolutions like ESMTP and LMTP. The event driven object-oriented API makes easy to incorporate the SMTP protocol to your programs. Other SMTPd implementations don't support useful ESMTP extensions and the LMTP protocol. Their interface design precludes adding them later. So I've decided to rewrite a complete implementation with extensibility in mind. It provides mechanism to easy addition future or not yet implemented ESMTP extensions. Developers can hook code at each SMTP session state and change the module's behaviors by registering event call-backs. The class is designed to be easily inherited from. This class is the base class for mail service protocols such as B, B and B. Refer to the documentation provided with each of these modules. =head1 METHODS =head2 new $instance = Net::Server::Mail->new( [option => 'value', ...] ) options: =over 4 =item handle_in Sets the input handle, from which the server reads data. Defaults to STDIN. =item handle_out Sets the output handle, to which the server writes data. Defaults to STDOUT. =item socket Sets a socket to be used for server reads and writes instead of handles. =item error_sleep_time Number of seconds to wait for before printing an error message. This avoids some DoS attacks that attempt to flood the server with bogus commands. A value of 0 turns this feature off. Defaults to 0. =item idle_timeout Number of seconds a connection must remain idle before it is closed. A value of 0 turns this feature off. Defaults to 0. =back =cut sub new { my ( $proto, @args ) = @_; my $class = ref $proto || $proto; my $self = {}; bless( $self, $class ); return $self->init(@args); } sub init { my $self = shift; confess("odd number of arguments") if ( @_ % 2 ); my $options = $self->{options} = { handle_in => undef, handle_out => undef, socket => undef, error_sleep_time => 0, idle_timeout => 0, }; for ( my $i = 0 ; $i < @_ ; $i += 2 ) { $options->{ lc( $_[$i] ) } = $_[ $i + 1 ]; } if ( defined $options->{handle_in} && defined $options->{handle_out} ) { if ( UNIVERSAL::isa( $options->{handle_in}, 'IO::Handle' ) ) { $self->{in} = $options->{handle_in}; } else { $self->{in} = IO::Handle->new->fdopen( fileno( $options->{handle_in} ), "r" ); } if ( UNIVERSAL::isa( $options->{handle_out}, 'IO::Handle' ) ) { $self->{out} = $options->{handle_out}; } else { $self->{out} = IO::Handle->new->fdopen( fileno( $options->{handle_out} ), "w" ); } } elsif ( defined $options->{'socket'} ) { $self->{in} = $options->{'socket'}; $self->{out} = $options->{'socket'}; } else { $self->{in} = IO::Handle->new->fdopen( fileno(STDIN), "r" ); $self->{out} = IO::Handle->new->fdopen( fileno(STDOUT), "w" ); } $self->{out}->autoflush(1); $self->{process_operation} = \&process_operation; return $self; } =pod =head2 dojob Some commands need to do a job after the handler call. The handler may want to override this to prevent the job from being executed. By calling this method with a (defined) false value as an argument, the expected job isn't executed. Defaults to true. =cut sub init_dojob { shift->{_dojob} = 1; } sub dojob { my ( $self, $bool ) = @_; $self->{_dojob} = $bool if ( defined $bool ); return $self->{_dojob}; } sub make_event { my $self = shift; confess('odd number of arguments') if ( @_ % 2 ); my %args = @_; my $name = $args{'name'} || confess('missing argument: \'name\''); my $args = defined $args{'arguments'} && ref $args{'arguments'} eq 'ARRAY' ? $args{'arguments'} : []; $self->init_dojob(); my ( $success, $code, $msg ) = $self->callback( $name, @{$args} ); # we have to take a proper decision if successness is undefined if ( not defined $success ) { if ( exists $args{'default_reply'} ) { if ( ref $args{'default_reply'} eq 'ARRAY' ) { ( $success, $code, $msg ) = $args{'default_reply'}; $success = 0 unless defined $success; } else { $success = $args{'default_reply'}; } } else { $success = 1; # default } } # command may have some job to do regarding to the result. handler # can avoid it by calling dojob() method with a false value. if ( $self->dojob() ) { if ($success) { if ( defined $args{'on_success'} and ref $args{'on_success'} eq 'CODE' ) { &{ $args{'on_success'} }; } } else { if ( defined $args{'on_failure'} and ref $args{'on_failure'} eq 'CODE' ) { &{ $args{'on_failure'} }; } } } # ensure that a reply is sent, all SMTP command need at most 1 reply. # some events such as 'stop_session' don't require sending reply. unless ( defined $code && !$args{'no_reply'} ) { if ( defined $success && $success ) { ( $code, $msg ) = $self->get_default_reply( $args{'success_reply'}, 250 ); } else { ( $code, $msg ) = $self->get_default_reply( $args{'failure_reply'}, 550 ); } } die "return code `$code' isn't numeric" if ( defined $code && $code =~ /\D/ ); $self->handle_reply( $name, $success, $code, $msg ) if defined $code and length $code; return $success; } sub get_default_reply { my ( $self, $config, $default ) = @_; my ( $code, $msg ); if ( defined $config ) { if ( ref $config eq 'ARRAY' ) { ( $code, $msg ) = @$config; } elsif ( not ref $config ) { $code = $config; } else { confess("unexpected format for reply"); } } else { $code = $default; } return ( $code, $msg ); } sub handle_reply { my ( $self, $verb, $success, $code, $msg ) = @_; # don't reply anything if code is empty $self->reply( $code, $msg ) if ( length $code ); } sub callback { my ( $self, $name, @args ) = @_; if ( defined $self->{callback}->{$name} ) { my @rv; eval { my ( $code, $context ) = @{ $self->{callback}->{$name} }; $self->set_context($context); @rv = &{$code}( $self, @args ); }; if ($@) { confess $@; } return @rv; } return 1; } sub set_context { my ( $self, $context ) = @_; $self->{_context} = $context; } sub get_context { my ($self) = @_; return $self->{_context}; } =pod =head2 set_callback ($success, $code, $msg) = $obj->set_callback(VERB, \&function, $context)> Sets the callback code to be called on a particular event. The function should return 1 to 3 values: (success, [return_code, ["message"]]). $mailserver->set_callback ( 'RCPT', sub { my($address) = @_; if(is_relayed($address)) { # default success code/message will be used return 1; } else { return(0, 513, 'Relaying denied.'); } } ); =cut sub set_callback { my ( $self, $name, $code, $context ) = @_; confess('bad callback() invocation') unless defined $code && ref $code eq 'CODE'; $self->{callback}->{$name} = [ $code, $context ]; } sub def_verb { my ( $self, $verb, $coderef ) = @_; $self->{verb}->{ uc $verb } = $coderef; } sub undef_verb { my ( $self, $verb ) = @_; delete $self->{verb}->{$verb} if defined $self->{verb}; } sub list_verb { my ($self) = @_; return keys %{ $self->{verb} }; } sub next_input_to { my ( $self, $method_ref ) = @_; $self->{next_input} = $method_ref if ( defined $method_ref ); return $self->{next_input}; } sub tell_next_input_method { my ( $self, $input ) = @_; # calling the method and reinitialize. Note: we have to reinit # before calling the code, because code can resetup this variable. my $code = $self->{next_input}; undef $self->{next_input}; my $rv = &{$code}( $self, $input ); return $rv; } =pod =head2 process $mailserver->process; Start a new session. =cut sub process { my ($self) = @_; my $in = $self->{in}; my $sel = IO::Select->new; $sel->add($in); $self->banner; # switch to non-blocking socket to handle PIPELINING # ESMTP extension. See RFC 2920 for more details. if ( $^O eq 'MSWin32' ) { # win32 platforms don't support nonblocking IO ioctl( $in, 2147772030, 1 ); } else { defined( $in->blocking(0) ) or die "Couldn't set nonblocking: $^E"; } my $buffer = ""; while (1) { # wait for data and read it my $rv = undef; if ( $sel->can_read( $self->{options}->{idle_timeout} || undef ) ) { if ( $^O eq 'MSWin32' ) { # see how much data is available to read my $size = pack( "L", 0 ); ioctl( $in, 1074030207, $size ); $size = unpack( "L", $size ); # read the data to $buffer $rv = sysread( $in, $buffer, $size, length($buffer) ); } else { $rv = sysread( $in, $buffer, 512 * 1024, length($buffer) ); } } else { # timeout return $self->timeout; } if ( ( not defined $rv ) or ( $rv == 0 ) ) { # read error or connection closed return $self->stop_session((not defined $rv) ? ($!) : ()); } # process all terminated lines # Note: Should accept only CRLF according to RFC. We accept # plain LFs anyway because its more liberal and works as well. my $newline_idx = rindex( $buffer, "\n" ); if ( $newline_idx >= 0 ) { # one or more lines, terminated with \r?\n my $chunk = substr( $buffer, 0, $newline_idx + 1 ); # remaining buffer $buffer = substr( $buffer, $newline_idx + 1 ); my $rv; if ( defined $self->next_input_to() ) { $rv = $self->tell_next_input_method($chunk); } else { $rv = $self->{process_operation}( $self, $chunk ); } # if $rv is defined, we have to close the connection if ( defined $rv ) { return $rv; } } # limit the size of lines to protect from excessive memory consumption # (RFC specifies 1000 bytes including \r\n) if ( length($buffer) > 1000 ) { $self->make_event( name => 'linetobig', success_reply => [ 552, 'line too long' ] ); return 1; } } return 1; } sub process_once { my ( $self, $operation ) = @_; if ( $self->next_input_to() ) { return $self->tell_next_input_method($operation); } else { return $self->{process_operation}( $self, $operation ); } } sub process_operation { my ( $self, $operation ) = @_; my ( $verb, $params ) = $self->tokenize_command($operation); if ( defined $params && $params =~ /[\r\n]/ ) { # doesn't support grouping of operations $self->reply( 453, "Command received prior to completion of" . " previous command sequence" ); return; } $self->process_command( $verb, $params ); } sub process_command { my ( $self, $verb, $params ) = @_; if ( exists $self->{verb}->{$verb} ) { my $action = $self->{verb}->{$verb}; my $rv; if ( ref $action eq 'CODE' ) { $rv = &{ $self->{verb}->{$verb} }( $self, $params ); } else { $rv = $self->$action($params); } return $rv; } else { $self->reply( 500, 'Syntax error: unrecognized command' ); return; } } sub tokenize_command { my ( $self, $line ) = @_; $line =~ s/\r?\n$//s; $line =~ s/^\s+|\s+$//g; my ( $verb, $params ) = split ' ', $line, 2; return ( uc($verb), $params ); } sub reply { my ( $self, $code, $msg ) = @_; my $out = $self->{out}; # tempo on error sleep $self->{options}->{error_sleep_time} if ( $code >= 400 && $self->{options}->{error_sleep_time} ); # default message $msg = $code >= 400 ? 'Failure' : 'Ok' unless defined $msg; # handle multiple lines my @lines; if ( ref $msg ) { confess "bad argument" unless ref $msg eq 'ARRAY'; @lines = @$msg; } else { @lines = split( /\r?\n/, $msg ); } for ( my $i = 0 ; $i < @lines ; $i++ ) { # RFC says that all lines but the last must # split the code and the message with a dash (-) my $sep = $i == $#lines ? ' ' : '-'; print $out "$code$sep$lines[$i]\r\n"; } } sub get_hostname { my ($self) = @_; return HOSTNAME; } sub get_protoname { my ($self) = @_; return 'NOPROTO'; } sub get_appname { my ($self) = @_; return 'Net::Server::Mail (Perl)'; } ########################################################### =pod =head2 banner Send the introduction banner. You have to call it manually when are using process_once() method. Don't use it with process() method. =head1 EVENTS =head2 banner Append at the opening of a new connection. Handler takes no argument. =cut sub banner { my ($self) = @_; unless ( defined $self->{banner_string} ) { my $hostname = $self->get_hostname || ''; my $protoname = $self->get_protoname || ''; my $appname = $self->get_appname || ''; my $str; $str = $hostname . ' ' if length $hostname; $str .= $protoname . ' ' if length $protoname; $str .= $appname . ' ' if length $appname; $str .= 'Service ready'; $self->{banner_string} = $str; } $self->make_event( name => 'banner', success_reply => [ 220, $self->{banner_string} ], failure_reply => [ '', '' ], ); } =pod =head2 timeout This event append where timeout is exceeded. Handler takes no argument. =cut sub timeout { my ($self) = @_; $self->make_event( name => 'timeout', success_reply => [ 421, $self->get_hostname . ' Timeout exceeded, closing transmission channel' ], ); return 1; } =pod =head2 timeout This event append where connection is closed or an error occurs during reading from socket. Takes the error description as an argument if an error occured and the argument is undefined if the session was closed by peer. $mailserver->set_callback ( 'stop_session', sub { my($session, $err) = @_; if( defined $err ) { print "Error occured during processing: $err\n"; } else { print "Session closed py peer\n"; } return 1; } ); =cut sub stop_session { my ($self, $err) = @_; $self->make_event( name => 'stop_session', arguments => [$err], no_reply => 1, ); return 1; } =pod =head1 SEE ALSO Please, see L, L and L. =head1 AUTHOR Olivier Poitrey Ers@rhapsodyk.netE =head1 AVAILABILITY Available on CPAN. anonymous Git repository: git clone git://github.com/rs/net-server-mail.git Git repository on the web: L =head1 BUGS Please use CPAN system to report a bug (http://rt.cpan.org/). =head1 LICENCE This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA =head1 COPYRIGHT =over =item Copyright (C) 2002 - Olivier Poitrey =item Copyright (C) 2007-2013 - Xavier Guimard =back =head2 STARTTLS =over =item Copyright (C) 2009 - Dan Moore =item Copyright (C) 2013 - Mytram =item Copyright (C) 2013 - Xavier Guimard =back =head2 Contributors =over =item 2012 - Georg Hoesch (patch to reduce memory consumption) =back =cut 1; Net-Server-Mail-0.23/META.yml0000644000175000017500000000124212642204104015131 0ustar xavierxavier--- abstract: 'Class to easily create a mail server' author: - 'Xavier Guimard ' build_requires: Test::Most: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.0401, CPAN::Meta::Converter version 2.150005' license: open_source meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Net-Server-Mail no_index: directory: - t - inc requires: IO::Socket::SSL: '1.831' Net::SMTP: '0' perl: '5.008' resources: repository: https://github.com/rs/net-server-mail version: '0.23' x_serialization_backend: 'CPAN::Meta::YAML version 0.012'