diff options
| -rw-r--r-- | README.md | 17 | ||||
| -rw-r--r-- | cpanfile | 3 | ||||
| -rw-r--r-- | lib/App/ImapNotify.pm | 44 | ||||
| -rw-r--r-- | lib/App/ImapNotify/ImapClient.pm | 31 | ||||
| -rw-r--r-- | lib/App/ImapNotify/Socket/SSL.pm | 20 | ||||
| -rwxr-xr-x | script/imap-notify.pl | 2 | ||||
| -rw-r--r-- | t/01_basic.t | 2 | ||||
| -rw-r--r-- | t/02_noop.t | 2 | ||||
| -rw-r--r-- | t/03_other_mailbox.t | 2 | ||||
| -rw-r--r-- | t/04_reconnect.t | 66 | ||||
| -rw-r--r-- | t/05_reconnect_noop.t | 70 | ||||
| -rw-r--r-- | t/06_early_connection_loss.t | 73 |
12 files changed, 301 insertions, 31 deletions
@@ -22,3 +22,20 @@ it under the same terms as Perl itself. # AUTHOR Florian Pritz <bluewind@xinu.at> + +### loop\_reconnect + + $app->loop_reconnect(); + +Same as loop(), but automatcally calls loop() again if the connection is lost. + +### loop + + $app->loop(); + +Open a connection and wait for NOTIFY notifications. When a NOTIFY notification +arrives, show a notification to the user. + +This method throws an exception when the connection to the server is lost. If +you want to continue waiting for new notifications, you may call this method +again. Also look at loop\_reconnect(). @@ -3,6 +3,8 @@ requires 'IO::Socket::SSL'; requires 'Log::Any'; requires 'Log::Any::Adapter'; requires 'MCE::Hobo'; +requires 'Path::Tiny'; +requires 'Syntax::Keyword::Try'; requires 'Time::Out'; requires 'autodie'; requires 'perl', 'v5.24.0'; @@ -13,6 +15,7 @@ on configure => sub { on test => sub { requires 'Test::Differences'; + requires 'Test::Exception'; requires 'Test::MockObject'; requires 'Test::More', '0.98'; }; diff --git a/lib/App/ImapNotify.pm b/lib/App/ImapNotify.pm index e7aba6f..b7b1cf7 100644 --- a/lib/App/ImapNotify.pm +++ b/lib/App/ImapNotify.pm @@ -11,6 +11,7 @@ use App::ImapNotify::Notifier; use Carp; use Function::Parameters; use Log::Any qw($log); +use Syntax::Keyword::Try; =encoding utf-8 @@ -55,10 +56,47 @@ method new_no_defaults($class: $config, $deps = {}) { return $self; } +=head3 loop_reconnect + + $app->loop_reconnect(); + +Same as loop(), but automatcally calls loop() again if the connection is lost. + +=cut + +method loop_reconnect() { + my $holdoff_time = 10; + my $holdoff_repeat = 0; + my $holdoff_limit = 300; + + while (1) { + my $last_time = time; + try { + $self->loop(); + } catch { + die $@ unless $@ =~ m/^Lost connection while .*/; + } + $holdoff_repeat = 0 if (time - $last_time) > $holdoff_limit; + sleep($holdoff_time * $holdoff_repeat++); + } +} + +=head3 loop + + $app->loop(); + +Open a connection and wait for NOTIFY notifications. When a NOTIFY notification +arrives, show a notification to the user. + +This method throws an exception when the connection to the server is lost. If +you want to continue waiting for new notifications, you may call this method +again. Also look at loop_reconnect(). + +=cut + method loop() { - #my $imap = $self->{deps}->{imap_client}->connect($self->{config}->@{qw(host port log_id)}); - #$imap->login($self->{config}->@{qw(username password)}); my $imap = $self->{deps}->{imap_client}; + $imap->reconnect(); $imap->select($self->{config}->{mailboxes}->@[0]); $imap->send_command("notify set (selected (MessageExpunge MessageNew (uid body.peek[header.fields (from to subject)]))) (mailboxes (".join(' ', $self->{config}->{mailboxes}->@*).") (MessageNew MessageExpunge MailboxName))"); @@ -75,8 +113,6 @@ method loop() { my $mailbox = $+{mailbox}; my $uid = $+{uidnext} - 1; $log->debugf("Got status change: '%s'", $line =~ s/\r\n$//r); - #$imap2->select($mailbox); - #my $message = $imap2->send_command("uid fetch $uid (body.peek[header.fields (from to subject)])"); $imap->select($mailbox); my $message = $imap->send_command("uid fetch $uid (body.peek[header.fields (from to subject)])"); pop @{$message}; diff --git a/lib/App/ImapNotify/ImapClient.pm b/lib/App/ImapNotify/ImapClient.pm index 6e5e21b..ae91c78 100644 --- a/lib/App/ImapNotify/ImapClient.pm +++ b/lib/App/ImapNotify/ImapClient.pm @@ -53,27 +53,33 @@ method new_no_defaults($class: $config, $deps = {}) { $self->{keepalive_timeout} = $config->{keepalive_timeout}; $self->{line_buffer} = []; $self->{deps} = $deps; - $self->_connect(); - $self->_login($config->@{qw(username password)}); + $self->{config} = $config; return $self; } -method _connect() { - # wait for server greeting +method reconnect() { + $self->{command_counter} = 0; + $self->{deps}->{sock}->reconnect(); my $response = $self->readline_block(); + croak("Lost connection while waiting for server greeting") if not defined $response; + if ($response !~ m/^\* OK (.*)/) { - confess "Invalid server greeting. Got reply: $response"; + confess "Invalid server greeting. Got reply: '$response'"; } $self->{capabilities} = $1; + + $self->_login(); } -method _login($username, $password) { +method _login() { if ($self->{capabilities} !~ m/\bAUTH=PLAIN\b/) { croak "Server doesn't support AUTH=PLAIN"; } - my $response = $self->send_command("login $username $password"); + my $response = $self->send_command("login $self->{config}->{username} $self->{config}->{password}"); + return if not defined $response; + confess "No capabilities found in response: '".$response->[0]."'" unless $response->[0] =~ m/^OK \[(.*)\].*$/; $self->{capabilities} = $1; @@ -92,15 +98,10 @@ method select($mailbox) { method send_command($command) { - state $counter = 0; - - my $id = "CMD-".$counter++; + my $id = "CMD-".$self->{command_counter}++; chomp($command); - #print "Sending $command\n"; - #sleep (5) if $command eq "noop"; - $self->writeline("$id $command\r\n"); my @lines; @@ -125,8 +126,10 @@ method send_command($command) { if ($line =~ /^(.*\r\n)$/) { push @lines, $1; } - } + + croak("Lost connection while waiting for reply to command '$command'"); + return; } method get_uids($mailbox) { diff --git a/lib/App/ImapNotify/Socket/SSL.pm b/lib/App/ImapNotify/Socket/SSL.pm index 18d7ffa..2654cdc 100644 --- a/lib/App/ImapNotify/Socket/SSL.pm +++ b/lib/App/ImapNotify/Socket/SSL.pm @@ -8,24 +8,26 @@ use Function::Parameters; use IO::Socket::SSL; use Log::Any qw($log); -method new($class: $host, $port, $deps = {}) { - $deps->{sock} //= IO::Socket::SSL->new("$host:$port"); - return $class->new_no_defaults($deps); -} - -method new_no_defaults($class: $deps = {}) { +method new($class: $host, $port) { my $self = {}; + $self->{config} = { + host => $host, + port => $port, + }; bless $self, $class; - $self->{deps} = $deps; return $self; } +method reconnect() { + $self->{sock} = IO::Socket::SSL->new("$self->{config}->{host}:$self->{config}->{port}"); +} + method readline() { - return CORE::readline $self->{deps}->{sock}; + return CORE::readline $self->{sock}; } method writeline($line) { - print {$self->{deps}->{sock}} $line; + print {$self->{sock}} $line; } diff --git a/script/imap-notify.pl b/script/imap-notify.pl index d540e76..234c5e8 100755 --- a/script/imap-notify.pl +++ b/script/imap-notify.pl @@ -101,7 +101,7 @@ for my $single_conf ($config->{watches}->@*) { $single_conf->{password} = `$single_conf->{passwordeval}`; push @workers, mce_async { my $app = App::ImapNotify->new($single_conf); - $app->loop(); + $app->loop_reconnect(); } } diff --git a/t/01_basic.t b/t/01_basic.t index 6f9d076..7afc839 100644 --- a/t/01_basic.t +++ b/t/01_basic.t @@ -31,7 +31,7 @@ $socket->set_series('readline', ")\r\n", ); -$socket->set_true(qw(writeline)); +$socket->set_true(qw(writeline reconnect)); my $config = { log_id => 'test-id1', diff --git a/t/02_noop.t b/t/02_noop.t index f1d4ab5..d479efc 100644 --- a/t/02_noop.t +++ b/t/02_noop.t @@ -39,7 +39,7 @@ my @input_lines = ( my $socket = Test::MockObject->new(); $socket->mock('readline', sub {my $x = shift @input_lines; ref($x) eq "CODE" ? $x->() : $x;}); -$socket->set_true(qw(writeline)); +$socket->set_true(qw(writeline reconnect)); my $config = { log_id => 'test-id1', diff --git a/t/03_other_mailbox.t b/t/03_other_mailbox.t index a1ef59a..443fc68 100644 --- a/t/03_other_mailbox.t +++ b/t/03_other_mailbox.t @@ -47,7 +47,7 @@ my @input_lines = ( my $socket = Test::MockObject->new(); $socket->mock('readline', sub {my $x = shift @input_lines; ref($x) eq "CODE" ? $x->() : $x;}); -$socket->set_true(qw(writeline)); +$socket->set_true(qw(writeline reconnect)); my $config = { log_id => 'test-id1', diff --git a/t/04_reconnect.t b/t/04_reconnect.t new file mode 100644 index 0000000..987db8e --- /dev/null +++ b/t/04_reconnect.t @@ -0,0 +1,66 @@ +use strict; +use warnings; +use Test::Differences; +use Test::More; +use Test::MockObject; + +use Log::Any::Adapter ('Stderr', log_level => "warn"); + +use App::ImapNotify; +use App::ImapNotify::ImapClient; + +=head1 DESCRIPTION + +Simulate a connection loss (readline on socket returns undef). + +=cut + +my @input_lines = ( + "* OK [CAPABILITY IMAP4rev1 SASL-IR LOGIN-REFERRALS ID ENABLE IDLE LITERAL+ AUTH=PLAIN AUTH=LOGIN] Fake server ready.\r\n", + "CMD-0 OK [CAPABILITY IMAP4rev1 SASL-IR LOGIN-REFERRALS ID ENABLE IDLE SORT SORT=DISPLAY THREAD=REFERENCES THREAD=REFS THREAD=ORDEREDSUBJECT MULTIAPPEND URL-PARTIAL CATENATE UNSELECT CHILDREN NAMESPACE UIDPLUS LIST-EXTENDED I18NLEVEL=1 CONDSTORE QRESYNC ESEARCH ESORT SEARCHRES WITHIN CONTEXT=SEARCH LIST-STATUS BINARY MOVE SNIPPET=FUZZY LITERAL+ NOTIFY SPECIAL-USE COMPRESS=DEFLATE] Logged in\r\n", + "CMD-1 OK [READ-WRITE] Select completed (0.001 + 0.000 secs).\r\n", + "CMD-2 OK NOTIFY completed (0.001 + 0.000 secs).\r\n", + # "connection loss" + undef, + # client should reconnect + "* OK [CAPABILITY IMAP4rev1 SASL-IR LOGIN-REFERRALS ID ENABLE IDLE LITERAL+ AUTH=PLAIN AUTH=LOGIN] Fake server ready.\r\n", + "CMD-0 OK [CAPABILITY IMAP4rev1 SASL-IR LOGIN-REFERRALS ID ENABLE IDLE SORT SORT=DISPLAY THREAD=REFERENCES THREAD=REFS THREAD=ORDEREDSUBJECT MULTIAPPEND URL-PARTIAL CATENATE UNSELECT CHILDREN NAMESPACE UIDPLUS LIST-EXTENDED I18NLEVEL=1 CONDSTORE QRESYNC ESEARCH ESORT SEARCHRES WITHIN CONTEXT=SEARCH LIST-STATUS BINARY MOVE SNIPPET=FUZZY LITERAL+ NOTIFY SPECIAL-USE COMPRESS=DEFLATE] Logged in\r\n", + "CMD-1 OK [READ-WRITE] Select completed (0.001 + 0.000 secs).\r\n", + "CMD-2 OK NOTIFY completed (0.001 + 0.000 secs).\r\n", +); + +my $socket = Test::MockObject->new(); +$socket->mock('readline', sub {my $x = shift @input_lines; ref($x) eq "CODE" ? $x->() : $x;}); +$socket->set_true(qw(writeline reconnect)); + +my $config = { + log_id => 'test-id1', + host => 'localhost.localdomain', + port => 993, + username => 'tester1', + password => 'secretPW42', + mailboxes => [qw(INBOX INBOX.test)], + keepalive_timeout => 300, +}; + +my $imap_client = App::ImapNotify::ImapClient->new_no_defaults($config, {sock => $socket}); + +my $app = App::ImapNotify->new_no_defaults($config, {imap_client => $imap_client}); + +$app->loop(); +$app->loop(); + +is(scalar(@input_lines), 0, "all input lines are read"); + +eq_or_diff([grep { $_->[0] eq "writeline" } $socket->_calls()->@*], [ + ['writeline', [$socket, "CMD-0 login tester1 secretPW42\r\n"]], + ['writeline', [$socket, "CMD-1 select INBOX\r\n"]], + ['writeline', [$socket, "CMD-2 notify set (selected (MessageExpunge MessageNew (uid body.peek[header.fields (from to subject)]))) (mailboxes (INBOX INBOX.test) (MessageNew MessageExpunge MailboxName))\r\n"]], + ['writeline', [$socket, "CMD-0 login tester1 secretPW42\r\n"]], + ['writeline', [$socket, "CMD-1 select INBOX\r\n"]], + ['writeline', [$socket, "CMD-2 notify set (selected (MessageExpunge MessageNew (uid body.peek[header.fields (from to subject)]))) (mailboxes (INBOX INBOX.test) (MessageNew MessageExpunge MailboxName))\r\n"]], + ], "socket writeline is called correctly"); + +is(scalar(grep { $_->[0] eq "reconnect" } $socket->_calls()->@*), 2, "socket reconnect is called twice"); + +done_testing; diff --git a/t/05_reconnect_noop.t b/t/05_reconnect_noop.t new file mode 100644 index 0000000..008b461 --- /dev/null +++ b/t/05_reconnect_noop.t @@ -0,0 +1,70 @@ +use strict; +use warnings; +use Test::Differences; +use Test::More; +use Test::MockObject; +use Test::Exception; + +use Log::Any::Adapter ('Stderr', log_level => "warn"); + +use App::ImapNotify; +use App::ImapNotify::ImapClient; + +=head1 DESCRIPTION + +Simulate a connection loss when sending noop (readline on socket returns undef). + +=cut + +my @input_lines = ( + "* OK [CAPABILITY IMAP4rev1 SASL-IR LOGIN-REFERRALS ID ENABLE IDLE LITERAL+ AUTH=PLAIN AUTH=LOGIN] Fake server ready.\r\n", + "CMD-0 OK [CAPABILITY IMAP4rev1 SASL-IR LOGIN-REFERRALS ID ENABLE IDLE SORT SORT=DISPLAY THREAD=REFERENCES THREAD=REFS THREAD=ORDEREDSUBJECT MULTIAPPEND URL-PARTIAL CATENATE UNSELECT CHILDREN NAMESPACE UIDPLUS LIST-EXTENDED I18NLEVEL=1 CONDSTORE QRESYNC ESEARCH ESORT SEARCHRES WITHIN CONTEXT=SEARCH LIST-STATUS BINARY MOVE SNIPPET=FUZZY LITERAL+ NOTIFY SPECIAL-USE COMPRESS=DEFLATE] Logged in\r\n", + "CMD-1 OK [READ-WRITE] Select completed (0.001 + 0.000 secs).\r\n", + "CMD-2 OK NOTIFY completed (0.001 + 0.000 secs).\r\n", + # wait for client to send noop + sub {sleep 10; fail("Keepalive failed to kill readline() operation");}, + # "connection loss" + undef, + # client should reconnect + "* OK [CAPABILITY IMAP4rev1 SASL-IR LOGIN-REFERRALS ID ENABLE IDLE LITERAL+ AUTH=PLAIN AUTH=LOGIN] Fake server ready.\r\n", + "CMD-0 OK [CAPABILITY IMAP4rev1 SASL-IR LOGIN-REFERRALS ID ENABLE IDLE SORT SORT=DISPLAY THREAD=REFERENCES THREAD=REFS THREAD=ORDEREDSUBJECT MULTIAPPEND URL-PARTIAL CATENATE UNSELECT CHILDREN NAMESPACE UIDPLUS LIST-EXTENDED I18NLEVEL=1 CONDSTORE QRESYNC ESEARCH ESORT SEARCHRES WITHIN CONTEXT=SEARCH LIST-STATUS BINARY MOVE SNIPPET=FUZZY LITERAL+ NOTIFY SPECIAL-USE COMPRESS=DEFLATE] Logged in\r\n", + "CMD-1 OK [READ-WRITE] Select completed (0.001 + 0.000 secs).\r\n", + "CMD-2 OK NOTIFY completed (0.001 + 0.000 secs).\r\n", +); + +my $socket = Test::MockObject->new(); +$socket->mock('readline', sub {my $x = shift @input_lines; ref($x) eq "CODE" ? $x->() : $x;}); +$socket->set_true(qw(writeline reconnect)); + +my $config = { + log_id => 'test-id1', + host => 'localhost.localdomain', + port => 993, + username => 'tester1', + password => 'secretPW42', + mailboxes => [qw(INBOX INBOX.test)], + keepalive_timeout => 0.01, +}; + +my $imap_client = App::ImapNotify::ImapClient->new_no_defaults($config, {sock => $socket}); + +my $app = App::ImapNotify->new_no_defaults($config, {imap_client => $imap_client}); + +throws_ok {$app->loop();} qr/^Lost connection while waiting for reply to command 'noop'/, "Expect connection loss"; +$app->loop(); + +is(scalar(@input_lines), 0, "all input lines are read"); + +eq_or_diff([grep { $_->[0] eq "writeline" } $socket->_calls()->@*], [ + ['writeline', [$socket, "CMD-0 login tester1 secretPW42\r\n"]], + ['writeline', [$socket, "CMD-1 select INBOX\r\n"]], + ['writeline', [$socket, "CMD-2 notify set (selected (MessageExpunge MessageNew (uid body.peek[header.fields (from to subject)]))) (mailboxes (INBOX INBOX.test) (MessageNew MessageExpunge MailboxName))\r\n"]], + ['writeline', [$socket, "CMD-3 noop\r\n"]], + ['writeline', [$socket, "CMD-0 login tester1 secretPW42\r\n"]], + ['writeline', [$socket, "CMD-1 select INBOX\r\n"]], + ['writeline', [$socket, "CMD-2 notify set (selected (MessageExpunge MessageNew (uid body.peek[header.fields (from to subject)]))) (mailboxes (INBOX INBOX.test) (MessageNew MessageExpunge MailboxName))\r\n"]], + ], "socket writeline is called correctly"); + +is(scalar(grep { $_->[0] eq "reconnect" } $socket->_calls()->@*), 2, "socket reconnect is called twice"); + +done_testing; diff --git a/t/06_early_connection_loss.t b/t/06_early_connection_loss.t new file mode 100644 index 0000000..105ea29 --- /dev/null +++ b/t/06_early_connection_loss.t @@ -0,0 +1,73 @@ +use strict; +use warnings; +use Test::Differences; +use Test::More; +use Test::MockObject; +use Test::Exception; + +use Log::Any::Adapter ('Stderr', log_level => "trace"); + +use App::ImapNotify; +use App::ImapNotify::ImapClient; + +=head1 DESCRIPTION + +Simulate a connection loss during early stages of the connection. + +=cut + +my @input_lines = ( + "* OK [CAPABILITY IMAP4rev1 SASL-IR LOGIN-REFERRALS ID ENABLE IDLE LITERAL+ AUTH=PLAIN AUTH=LOGIN] Fake server ready.\r\n", + "CMD-0 OK [CAPABILITY IMAP4rev1 SASL-IR LOGIN-REFERRALS ID ENABLE IDLE SORT SORT=DISPLAY THREAD=REFERENCES THREAD=REFS THREAD=ORDEREDSUBJECT MULTIAPPEND URL-PARTIAL CATENATE UNSELECT CHILDREN NAMESPACE UIDPLUS LIST-EXTENDED I18NLEVEL=1 CONDSTORE QRESYNC ESEARCH ESORT SEARCHRES WITHIN CONTEXT=SEARCH LIST-STATUS BINARY MOVE SNIPPET=FUZZY LITERAL+ NOTIFY SPECIAL-USE COMPRESS=DEFLATE] Logged in\r\n", + "CMD-1 OK [READ-WRITE] Select completed (0.001 + 0.000 secs).\r\n", + "CMD-2 OK NOTIFY completed (0.001 + 0.000 secs).\r\n", +); + +my $socket = Test::MockObject->new(); +$socket->set_true(qw(writeline reconnect)); + +my $config = { + log_id => 'test-id1', + host => 'localhost.localdomain', + port => 993, + username => 'tester1', + password => 'secretPW42', + mailboxes => [qw(INBOX INBOX.test)], + keepalive_timeout => 300, +}; + +my $imap_client = App::ImapNotify::ImapClient->new_no_defaults($config, {sock => $socket}); + +my $app = App::ImapNotify->new_no_defaults($config, {imap_client => $imap_client}); + +$socket->set_series('readline', undef); +throws_ok {$app->loop();} qr/^Lost connection while waiting for server greeting/, "Expect connection loss"; +eq_or_diff([grep { $_->[0] eq "writeline" } $socket->_calls()->@*], [ + ], "Connection loss before receiving greeting"); +$socket->clear(); + +$socket->set_series('readline', @input_lines[0..0], undef); +throws_ok {$app->loop();} qr/^Lost connection while waiting for reply to command 'login tester1 secretPW42'/, "Expect connection loss"; +eq_or_diff([grep { $_->[0] eq "writeline" } $socket->_calls()->@*], [ + ['writeline', [$socket, "CMD-0 login tester1 secretPW42\r\n"]], + ], "Connection loss after sending login"); +$socket->clear(); + +$socket->set_series('readline', @input_lines[0..1], undef); +throws_ok {$app->loop();} qr/^Lost connection while waiting for reply to command 'select INBOX'/, "Expect connection loss"; +eq_or_diff([grep { $_->[0] eq "writeline" } $socket->_calls()->@*], [ + ['writeline', [$socket, "CMD-0 login tester1 secretPW42\r\n"]], + ['writeline', [$socket, "CMD-1 select INBOX\r\n"]], + ], "Connection loss after sending select"); +$socket->clear(); + +$socket->set_series('readline', @input_lines[0..2], undef); +throws_ok {$app->loop();} qr/^Lost connection while waiting for reply to command 'notify set \(.*\)'/, "Expect connection loss"; +eq_or_diff([grep { $_->[0] eq "writeline" } $socket->_calls()->@*], [ + ['writeline', [$socket, "CMD-0 login tester1 secretPW42\r\n"]], + ['writeline', [$socket, "CMD-1 select INBOX\r\n"]], + ['writeline', [$socket, "CMD-2 notify set (selected (MessageExpunge MessageNew (uid body.peek[header.fields (from to subject)]))) (mailboxes (INBOX INBOX.test) (MessageNew MessageExpunge MailboxName))\r\n"]], + ], "Connection loss after sending notify"); +$socket->clear(); + +done_testing; |