diff --git a/t/Mail/Send.t b/t/Mail/Send.t index 1b09bcafb..0f1516324 100644 --- a/t/Mail/Send.t +++ b/t/Mail/Send.t @@ -17,17 +17,15 @@ use lib "$FindBin::Bin/../lib"; use JSON qw( from_json to_json ); use Test::More; use Test::Deep; -use Data::Dumper; use MIME::Parser; use Encode qw/decode encode/; +use Try::Tiny; use WebGUI::Test; use WebGUI::Paths; use WebGUI::Mail::Send; -$| = 1; - #---------------------------------------------------------------------------- # Init my $session = WebGUI::Test->session; @@ -35,11 +33,6 @@ my $session = WebGUI::Test->session; my $mail; # The WebGUI::Mail::Send object my $mime; # for getMimeEntity -# See if we have an SMTP server to use -my $hasServer = 0; -eval { WebGUI::Test->prepareMailServer; $hasServer = 1 }; -if ( $@ ) { diag( "Can't prepare mail server: $@" ) } - #---------------------------------------------------------------------------- # Tests @@ -127,139 +120,119 @@ my $dbMail = WebGUI::Mail::Send->retrieve($session, $messageId); is($dbMail->getMimeEntity->head->get('List-ID'), "=?UTF-8?Q?H=C3=84ufige=20Fragen?=\n", 'addHeaderField: handles utf-8 correctly'); # TODO: Test that addHtml creates a body with the right content type -my $smtpServerOk = 0; + +my $smtpServerOk; #---------------------------------------------------------------------------- # Test emailOverride SKIP: { - my $numtests = 2; # Number of tests in this block - - # Must be able to write the config, or we'll die - if ( !-w File::Spec->catfile( WebGUI::Paths->configBase, WebGUI::Test->file ) ) { - skip "Cannot test emailOverride: Can't write new configuration value", $numtests; + try { + require WebGUI::Test::MailServer; + $smtpServerOk = 1; } + catch { + skip "Cannot run live SMTP tests: $_", 6; + }; - # Must have an SMTP server, or it's pointless - if ( !$hasServer ) { - skip "Cannot test emailOverride: Module Net::SMTP::Server not loaded!", $numtests; - } + WebGUI::Test::MailServer::test_smtp($session, sub { + my $cb = shift; - sleep 1; - $smtpServerOk = 1; + # Override the emailOverride + $session->config->set( 'emailOverride', 'dufresne@localhost' ); - # Override the emailOverride - my $oldEmailOverride = $session->config->get('emailOverride'); - $session->config->set( 'emailOverride', 'dufresne@localhost' ); + # Send the mail + my $mail + = WebGUI::Mail::Send->create( $session, { + to => 'norton@localhost', + } ); + $mail->addText( 'His judgement cometh and that right soon.' ); - # Send the mail - my $mail - = WebGUI::Mail::Send->create( $session, { - to => 'norton@localhost', - } ); - $mail->addText( 'His judgement cometh and that right soon.' ); + $mail->send; + my $received = $cb->(); - $mail->send; - my $received = WebGUI::Test->getMail; + # Test the mail + like( $received->{to}->[0], qr/dufresne\@localhost/, + "Email TO: address is overridden", + ); - if (!$received) { - skip "Cannot test emailOverride: No response received from smtpd", $numtests; - } + my $parser = MIME::Parser->new(); + $parser->output_to_core(1); + my $parsed_message = $parser->parse_data($received->{contents}); + my $head = $parsed_message->head; + my $messageId = decode('MIME-Header', $head->get('Message-Id')); + like ($messageId, qr/^$/, 'Message-Id is valid'); - # Test the mail - like( $received->{to}->[0], qr/dufresne\@localhost/, - "Email TO: address is overridden", - ); + $session->config->delete( 'emailOverride' ); - my $parser = MIME::Parser->new(); - $parser->output_to_core(1); - my $parsed_message = $parser->parse_data($received->{contents}); - my $head = $parsed_message->head; - my $messageId = decode('MIME-Header', $head->get('Message-Id')); - like ($messageId, qr/^$/, 'Message-Id is valid'); + # Send the mail + $mail + = WebGUI::Mail::Send->create( $session, { + to => 'norton@localhost', + } ); + $mail->addText( "I understand you're a man who knows how to get things." ); - # Restore the emailOverride - $session->config->set( 'emailOverride', $oldEmailOverride ); -} + $mail->send; + $received = $cb->(); -SKIP: { - my $numtests = 4; # Number of tests in this block + # Test the mail + my $parsed_message = $received->{parsed}; + my $head = $parsed_message->head; + my $messageId = decode('MIME-Header', $head->get('Message-Id')); + chomp $messageId; + like ($messageId, qr/^$/, 'generated Message-Id is valid'); - skip "Cannot test message ids", $numtests unless $smtpServerOk; + # Send the mail + $mail + = WebGUI::Mail::Send->create( $session, { + to => 'norton@localhost', + messageId => 'addText( "What say you there, fuzzy-britches? Feel like talking?" ); - # Send the mail - my $mail - = WebGUI::Mail::Send->create( $session, { - to => 'norton@localhost', - } ); - $mail->addText( "I understand you're a man who knows how to get things." ); + $mail->send; + $received = $cb->(); - $mail->send; - my $received = WebGUI::Test->getMail; + $parsed_message = $received->{parsed}; + $head = $parsed_message->head; + $messageId = decode('MIME-Header', $head->get('Message-Id')); + chomp $messageId; + is($messageId, '', 'bad messageId corrected (added ending angle)'); - if (!$received) { - skip "Cannot test messageIds: No response received from smtpd", $numtests; - } + # Send the mail + $mail + = WebGUI::Mail::Send->create( $session, { + to => 'norton@localhost', + messageId => 'endingAngleOnly@localhost.localdomain>', + } ); + $mail->addText( "Dear Warden, You were right. Salvation lies within." ); - # Test the mail - my $parser = MIME::Parser->new(); - $parser->output_to_core(1); - my $parsed_message = $parser->parse_data($received->{contents}); - my $head = $parsed_message->head; - my $messageId = decode('MIME-Header', $head->get('Message-Id')); - chomp $messageId; - like ($messageId, qr/^$/, 'generated Message-Id is valid'); + $mail->send; + $received = $cb->(); - # Send the mail - $mail - = WebGUI::Mail::Send->create( $session, { - to => 'norton@localhost', - messageId => 'addText( "What say you there, fuzzy-britches? Feel like talking?" ); + $parsed_message = $received->{parsed}; + $parsed_message = $parser->parse_data($received->{contents}); + $head = $parsed_message->head; + $messageId = decode('MIME-Header', $head->get('Message-Id')); + chomp $messageId; + is($messageId, '', 'bad messageId corrected (added starting angle)'); - $mail->send; - $received = WebGUI::Test->getMail; + # Send the mail + $mail + = WebGUI::Mail::Send->create( $session, { + to => 'red@localhost', + messageId => 'noAngles@localhost.localdomain', + } ); + $mail->addText( "Neither are they. You have to be human first. They don't qualify." ); - $parsed_message = $parser->parse_data($received->{contents}); - $head = $parsed_message->head; - $messageId = decode('MIME-Header', $head->get('Message-Id')); - chomp $messageId; - is($messageId, '', 'bad messageId corrected (added ending angle)'); - - # Send the mail - $mail - = WebGUI::Mail::Send->create( $session, { - to => 'norton@localhost', - messageId => 'endingAngleOnly@localhost.localdomain>', - } ); - $mail->addText( "Dear Warden, You were right. Salvation lies within." ); - - $mail->send; - $received = WebGUI::Test->getMail; - - $parsed_message = $parser->parse_data($received->{contents}); - $head = $parsed_message->head; - $messageId = decode('MIME-Header', $head->get('Message-Id')); - chomp $messageId; - is($messageId, '', 'bad messageId corrected (added starting angle)'); - - # Send the mail - $mail - = WebGUI::Mail::Send->create( $session, { - to => 'red@localhost', - messageId => 'noAngles@localhost.localdomain', - } ); - $mail->addText( "Neither are they. You have to be human first. They don't qualify." ); - - $mail->send; - $received = WebGUI::Test->getMail; - - $parsed_message = $parser->parse_data($received->{contents}); - $head = $parsed_message->head; - $messageId = decode('MIME-Header', $head->get('Message-Id')); - chomp $messageId; - is($messageId, '', 'bad messageId corrected (added both angles)'); + $mail->send; + $received = $cb->(); + $parsed_message = $received->{parsed}; + $head = $parsed_message->head; + $messageId = decode('MIME-Header', $head->get('Message-Id')); + chomp $messageId; + is($messageId, '', 'bad messageId corrected (added both angles)'); + }); } #---------------------------------------------------------------------------- @@ -292,24 +265,24 @@ WebGUI::Test->addToCleanup($inboxGroup); $inboxGroup->addUsers([$emailUser->userId, $inboxUser->userId, $lonelyUser->userId]); SKIP: { - my $numtests = 1; # Number of tests in this block + skip "Cannot test email notifications", 1 unless $smtpServerOk; - # Must be able to write the config, or we'll die - skip "Cannot test email notifications", $numtests unless $smtpServerOk; + WebGUI::Test::MailServer::test_smtp($session, sub { + my $cb = shift; + # Send the mail + $mail = WebGUI::Mail::Send->create( $session, { + toUser => $inboxUser->userId, + }, + 'fromInbox', + ); + $mail->addText( 'sent via email' ); - # Send the mail - $mail = WebGUI::Mail::Send->create( $session, { - toUser => $inboxUser->userId, - }, - 'fromInbox', - ); - $mail->addText( 'sent via email' ); + $mail->send; + my $received = $cb->(); - $mail->send; - my $received = WebGUI::Test->getMail; - - # Test the mail - is($received->{to}->[0], '', 'send, toUser with email address'); + # Test the mail + is($received->{to}->[0], '', 'send, toUser with email address'); + }); } #---------------------------------------------------------------------------- diff --git a/t/lib/WebGUI/Test.pm b/t/lib/WebGUI/Test.pm index a2d867b9c..e4fff6cef 100644 --- a/t/lib/WebGUI/Test.pm +++ b/t/lib/WebGUI/Test.pm @@ -523,57 +523,6 @@ sub getSmokeLDAPProps { #---------------------------------------------------------------------------- -=head2 prepareMailServer ( ) - -Prepare a Net::SMTP::Server to use for testing mail. - -=cut - -my $smtpdPid; -my $smtpdStream; -my $smtpdSelect; - -sub prepareMailServer { - eval { - require Net::SMTP::Server; - require Net::SMTP::Server::Client; - }; - croak "Cannot load Net::SMTP::Server: $@" if $@; - - my $SMTP_HOST = 'localhost'; - my $SMTP_PORT = '54921'; - my $smtpd = File::Spec->catfile( $CLASS->root, 't', 'smtpd.pl' ); - $smtpdPid = open $smtpdStream, '-|', $^X, $smtpd, $SMTP_HOST, $SMTP_PORT - or die "Could not open pipe to SMTPD: $!"; - - $smtpdSelect = IO::Select->new; - $smtpdSelect->add($smtpdStream); - - $CLASS->session->setting->set( 'smtpServer', $SMTP_HOST . ':' . $SMTP_PORT ); - - $CLASS->originalConfig('emailToLog'); - $CLASS->session->config->set( 'emailToLog', 0 ); - - # Let it start up yo - sleep 2; - - $CLASS->addToCleanup(sub { - # Close SMTPD - if ($smtpdPid) { - kill INT => $smtpdPid; - } - if ($smtpdStream) { - # we killed it, so there will be an error. Prevent that from setting the exit value. - local $?; - close $smtpdStream; - } - }); - - return; -} - -#---------------------------------------------------------------------------- - =head2 originalConfig ( $param ) Stores the original data from the config file, to be restored @@ -606,63 +555,6 @@ sub originalConfig { #---------------------------------------------------------------------------- -=head2 getMail ( ) - -Read a sent mail from the prepared mail server (L) - -=cut - -sub getMail { - my $json; - - if ( !$smtpdSelect ) { - return from_json ' { "error": "mail server not prepared" }'; - } - - if ($smtpdSelect->can_read(5)) { - $json = <$smtpdStream>; - } - else { - $json = ' { "error": "mail not sent" } '; - } - - if (!$json) { - $json = ' { "error": "error in getting mail" } '; - } - - return from_json( $json ); -} - -#---------------------------------------------------------------------------- - -=head2 getMailFromQueue ( ) - -Send the first mail in the queue and then retrieve it from the smtpd. Returns -false if there is no mail in the queue. - -Will prepare the server if necessary - -=cut - -sub getMailFromQueue { - my $class = shift; - if ( !$smtpdSelect ) { - $class->prepareMailServer; - } - - my $messageId = $CLASS->session->db->quickScalar( "SELECT messageId FROM mailQueue" ); - warn $messageId; - return unless $messageId; - - require WebGUI::Mail::Send; - my $mail = WebGUI::Mail::Send->retrieve( $CLASS->session, $messageId ); - $mail->send; - - return $class->getMail; -} - -#---------------------------------------------------------------------------- - =head2 cleanupGuard ( $object, $class => $ident ) Pass in a list of objects or pairs of classes and identifiers, and diff --git a/t/lib/WebGUI/Test/MailServer.pm b/t/lib/WebGUI/Test/MailServer.pm new file mode 100644 index 000000000..dad3bf3a5 --- /dev/null +++ b/t/lib/WebGUI/Test/MailServer.pm @@ -0,0 +1,137 @@ +package WebGUI::Test::MailServer; + +=head1 LEGAL + + ------------------------------------------------------------------- + WebGUI is Copyright 2001-2009 Plain Black Corporation. + ------------------------------------------------------------------- + Please read the legal notices (docs/legal.txt) and the license + (docs/license.txt) that came with this distribution before using + this software. + ------------------------------------------------------------------- + http://www.plainblack.com info@plainblack.com + ------------------------------------------------------------------- + +=head1 NAME + +Package WebGUI::Test::MailServer + +=head1 DESCRIPTION + +Routines for testing mail sending in WebGUI + +=cut + +use strict; +use warnings; + +use JSON (); +use File::Spec::Functions qw(catdir updir); +use File::Basename qw(dirname); +use IO::Select; +use Net::SMTP::Server; +use Net::SMTP::Server::Client; +use MIME::Parser; +use Scope::Guard; +use MIME::Parser; + +my $smtpdPid; +my $smtpdStream; +my $smtpdSelect; + +sub test_smtp { + my $session = shift; + my $testSub = shift; + my $guard = Scope::Guard->new(sub { _shutdown_server() } ); + _setup_server($session); + sleep 1; + my $parser = MIME::Parser->new; + $parser->output_to_core(1); + my $cb = sub { + die "mail not sent\n" + unless $smtpdSelect->can_read(5); + my $json = <$smtpdStream>; + my $data = JSON->new->utf8->decode($json); + my $parsed = $parser->parse_data($data->{contents}); + $data->{parsed} = $parsed; + return $data; + }; + $testSub->($cb); +} + +sub _setup_server { + my $session = shift; + return + if $smtpdPid; + + my $host = 'localhost'; + my $port = 54921; + + # make sure the lib path for this file is available + my $lib_path = catdir( dirname(__FILE__), (updir) x 2 ); + my @command_line = ( + $^X, "-I$lib_path", '-M' . __PACKAGE__, + '-e' . __PACKAGE__ . '::run_server(@ARGV)', $host, $port, + ); + + $smtpdPid = open $smtpdStream, '-|', @command_line + or die "Could not open pipe to SMTPD: $!"; + die "Could not open pipe to SMTPD: $!" + unless $smtpdStream; + + $smtpdSelect = IO::Select->new; + $smtpdSelect->add($smtpdStream); + + $session->setting->set( 'smtpServer', $host . ':' . $port ); + $session->config->set( 'emailToLog', 0 ); +} + +sub _shutdown_server { + undef $smtpdSelect; + + # Close SMTPD + if ($smtpdPid) { + kill INT => $smtpdPid; + undef $smtpdPid; + } + if ($smtpdStream) { + # we killed it, so there will be an error. Prevent that from setting the exit value. + local $?; + close $smtpdStream; + undef $smtpdStream; + } +} + +=head2 getMail ( ) + +Read a sent mail from the prepared mail server (L) + +=cut + +sub getMail { + my $json; + + if ($smtpdSelect->can_read(5)) { + $json = <$smtpdStream>; + } + return from_json( $json ); +} + +sub run_server { + my ($host, $port) = @_; + my $server = Net::SMTP::Server->new( $host, $port ); + local $| = 1; + CONNECTION: while ( my $conn = $server->accept ) { + my $client = Net::SMTP::Server::Client->new( $conn ); + $client->process; + print JSON->new->utf8->encode({ + to => $client->{TO}, + from => $client->{FROM}, + contents => $client->{MSG}, + }); + print "\n"; + } +} + +1; + diff --git a/t/smtpd.pl b/t/smtpd.pl deleted file mode 100644 index 57469e004..000000000 --- a/t/smtpd.pl +++ /dev/null @@ -1,50 +0,0 @@ -use strict; -use warnings; - -use JSON qw( to_json ); -use Net::SMTP::Server; -use Net::SMTP::Server::Client; - -my ($HOST, $PORT) = @ARGV; - -die "HOST must be first argument" - unless $HOST; -die "PORT must be second argument" - unless $PORT; - -my $server = Net::SMTP::Server->new( $HOST, $PORT ); - -$| = 1; - -CONNECTION: while ( my $conn = $server->accept ) { - my $client = Net::SMTP::Server::Client->new( $conn ); - $client->process; - print to_json({ - to => $client->{TO}, - from => $client->{FROM}, - contents => $client->{MSG}, - }); - print "\n"; -} - -=head1 NAME - -t/smtpd.pl - A dumb SMTP server. - -=head1 USAGE - - perl smtpd.pl - -=head1 DESCRIPTION - -This program listens on the given hostname and port, then processes the -incoming SMTP client request. - -Then it prints a JSON object of the data recieved and exits. - -This program will only handle one request before exiting. - -=head1 CAVEATS - -You MUST C after opening a pipe to this so that it can establish the -listening on the port.