diff options
-rw-r--r-- | META.json | 11 | ||||
-rw-r--r-- | README.md | 4 | ||||
-rw-r--r-- | cpanfile | 18 | ||||
-rw-r--r-- | lib/App/ImapNotify.pm | 95 | ||||
-rw-r--r-- | lib/App/ImapNotify/ImapClient.pm | 214 | ||||
-rw-r--r-- | lib/App/ImapNotify/Notifier.pm | 48 | ||||
-rw-r--r-- | lib/App/ImapNotify/Socket/SSL.pm | 34 | ||||
-rwxr-xr-x | script/imap-notify.pl | 58 | ||||
-rw-r--r-- | t/00_compile.t | 4 | ||||
-rw-r--r-- | t/01_basic.t | 58 | ||||
-rw-r--r-- | t/02_noop.t | 73 |
11 files changed, 607 insertions, 10 deletions
@@ -42,11 +42,20 @@ }, "runtime" : { "requires" : { - "perl" : "5.008001" + "Function::Parameters" : "0", + "IO::Socket::SSL" : "0", + "Log::Any" : "0", + "Log::Any::Adapter" : "0", + "MCE::Hobo" : "0", + "Time::Out" : "0", + "autodie" : "0", + "perl" : "v5.24.0" } }, "test" : { "requires" : { + "Test::Differences" : "0", + "Test::MockObject" : "0", "Test::More" : "0.98" } } @@ -8,7 +8,9 @@ App::ImapNotify - It's new $module # DESCRIPTION -App::ImapNotify is ... +App::ImapNotify is a simple notification script using IMAP NOTIFY. Note that it is very simple and +implements a custom IMAP client with very limited features. Mostly a proof of +concept and personal script. # LICENSE @@ -1,6 +1,18 @@ -requires 'perl', '5.008001'; +requires 'Function::Parameters'; +requires 'IO::Socket::SSL'; +requires 'Log::Any'; +requires 'Log::Any::Adapter'; +requires 'MCE::Hobo'; +requires 'Time::Out'; +requires 'autodie'; +requires 'perl', 'v5.24.0'; -on 'test' => sub { - requires 'Test::More', '0.98'; +on configure => sub { + requires 'Module::Build::Tiny', '0.035'; }; +on test => sub { + requires 'Test::Differences'; + requires 'Test::MockObject'; + requires 'Test::More', '0.98'; +}; diff --git a/lib/App/ImapNotify.pm b/lib/App/ImapNotify.pm index 4cf5354..0b44f68 100644 --- a/lib/App/ImapNotify.pm +++ b/lib/App/ImapNotify.pm @@ -1,14 +1,16 @@ package App::ImapNotify; -use 5.008001; +use v5.24; use strict; use warnings; our $VERSION = "0.01"; +use App::ImapNotify::ImapClient; +use App::ImapNotify::Notifier; - -1; -__END__ +use Carp; +use Function::Parameters; +use Log::Any qw($log); =encoding utf-8 @@ -22,7 +24,9 @@ App::ImapNotify - It's new $module =head1 DESCRIPTION -App::ImapNotify is ... +App::ImapNotify is a simple notification script using IMAP NOTIFY. Note that it is very simple and +implements a custom IMAP client with very limited features. Mostly a proof of +concept and personal script. =head1 LICENSE @@ -37,3 +41,84 @@ Florian Pritz E<lt>bluewind@xinu.atE<gt> =cut +method new($class: $config, $deps = {}) { + $deps->{imap_client} //= App::ImapNotify::ImapClient->new({$config->%{qw(host port log_id username password keepalive_timeout)}}); + $deps->{notifier} //= App::ImapNotify::Notifier->new(); + return $class->new_no_defaults($config, $deps); +} + +method new_no_defaults($class: $config, $deps = {}) { + my $self = {}; + bless $self, $class; + $self->{config} = $config; + $self->{deps} = $deps; + return $self; +} + +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->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))"); + + $log->info("Waiting for notify events"); + while (my $line = $imap->readline_timeout()) { + $log->tracef("Got line: '%s'", $line); + if ($line =~ m/^\* .* FETCH /) { + my $message = $imap->handle_fetch($line); + $self->_notify($message); + next; + } + if ($line =~ m/^\* STATUS (?<mailbox>[^ ]+) \(MESSAGES \d+ UIDNEXT (?<uidnext>\d+) UNSEEN \d+\)/) { + $log->debugf("Got status change: '%s'", $line); + my $mailbox = $+{mailbox}; + my $uid = $+{uidnext} - 1; + #$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}; + $self->_notify($message); + next; + } + + next if $line =~ /\* \d+ RECENT/; + next if $line =~ /\* \d+ EXISTS/; + next if $line =~ /\* \d+ EXPUNGE/; + + confess(sprintf("Got unexpected line: '%s'", $line)); + } +} + +method _notify($message) { + $log->debugf("Got data for notification: %s", $message); + my $fields = {}; + my $current_field; + + return if $message->@* == 0; + + for my $line ($message->@*) { + if ($line =~ m/^(?<label>[^\s:]+): (?<value>.*)\r\n$/) { + $current_field = lc($+{label}); + $fields->{$current_field} = $+{value}; + next; + } + + if ($line =~ m/^\s+(.*)$/) { + $fields->{$current_field} .= $1; + } + } + + $log->debugf("Sending notification with data: %s", $fields); + my $notify_heading = sprintf("From: %s", $fields->%*->@{qw(from)}); + my $notify_body = sprintf("Subject: %s", $fields->%*->@{qw(subject)}); + $self->{deps}->{notifier}->notify($notify_heading, $notify_body); +} + + + +1; +__END__ + diff --git a/lib/App/ImapNotify/ImapClient.pm b/lib/App/ImapNotify/ImapClient.pm new file mode 100644 index 0000000..6e5e21b --- /dev/null +++ b/lib/App/ImapNotify/ImapClient.pm @@ -0,0 +1,214 @@ +package App::ImapNotify::ImapClient; +use v5.24; +use strict; +use warnings; + +use App::ImapNotify::Socket::SSL; + +use autodie; +use Carp; +use Data::Dumper; +use Function::Parameters; +use Log::Any qw($log); +use Time::HiRes; +use Time::Out qw(timeout); + +=head1 NAME + +App::ImapNotify::ImapClient - ShortDesc + +=head1 SYNOPSIS + + use App::ImapNotify::ImapClient; + + # synopsis... + +=head1 DESCRIPTION + +# longer description... + + +=head1 INTERFACE + + +=head1 DEPENDENCIES + + +=head1 SEE ALSO + +L<App::ImapNotify> + +=cut + +method new($class: $config, $deps = {}) { + $deps->{sock} //= App::ImapNotify::Socket::SSL->new($config->@{qw(host port)}); + $config->{keepalive_timeout} //= 300; + return $class->new_no_defaults($config, $deps); +} + +method new_no_defaults($class: $config, $deps = {}) { + my $self = {}; + bless $self, $class; + $self->{log_id} = $config->{log_id}; + $self->{keepalive_timeout} = $config->{keepalive_timeout}; + $self->{line_buffer} = []; + $self->{deps} = $deps; + $self->_connect(); + $self->_login($config->@{qw(username password)}); + return $self; +} + +method _connect() { + # wait for server greeting + my $response = $self->readline_block(); + if ($response !~ m/^\* OK (.*)/) { + confess "Invalid server greeting. Got reply: $response"; + } + + $self->{capabilities} = $1; +} + +method _login($username, $password) { + if ($self->{capabilities} !~ m/\bAUTH=PLAIN\b/) { + croak "Server doesn't support AUTH=PLAIN"; + } + + my $response = $self->send_command("login $username $password"); + confess "No capabilities found in response: '".$response->[0]."'" unless $response->[0] =~ m/^OK \[(.*)\].*$/; + $self->{capabilities} = $1; + + if ($self->{capabilities} !~ m/\bNOTIFY\b/) { + croak "Server doesn't support NOTIFY"; + } +} + +method select($mailbox) { + # TODO: seems like select is needed to be able to access newly added UIDs. maybe find a better fix than removing this optimization or look in the standard what's going on here? + #if ($self->{current_mailbox} ne $mailbox) { + $self->send_command("select $mailbox"); + # $self->{current_mailbox} = $mailbox; + #} +} + + +method send_command($command) { + state $counter = 0; + + my $id = "CMD-".$counter++; + + chomp($command); + + #print "Sending $command\n"; + #sleep (5) if $command eq "noop"; + + $self->writeline("$id $command\r\n"); + + my @lines; + + while (my $line = $self->readline_block()) { + # TODO: this is probably not correct, but seems to be enough for now. a correct way should probably check that the fetch reply actually corresponds to the fetch command. probably best to check if the UID is the same. + if ($command =~ /^uid fetch /i and $line =~ /^(\* \d+ FETCH .*\r\n)/) { + push @lines, $self->handle_fetch($1)->@*; + next; + } elsif ($line =~/^(\* \d+ FETCH .*\r\n)/) { + push @lines, $line, $self->handle_fetch($1)->@*; + next; + } + + if ($line =~ m/^$id (OK .*\r\n)$/) { + push @lines, $1; + return \@lines; + } elsif ($line =~ /^$id /) { + croak "Command '$command' failed. Got reply: $line"; + } + + if ($line =~ /^(.*\r\n)$/) { + push @lines, $1; + } + + } +} + +method get_uids($mailbox) { + $self->select($mailbox); + my $response = $self->send_command("UID FETCH 1:* (UID)"); + pop @$response; + + @$response = map {s/^.* FETCH \(UID ([0-9]+)\)$/$1/r} @$response; + return $response; +} + +method handle_fetch($first_line) { + if ($first_line =~ m/^\* \d+ FETCH \(.* \{(?<bytes>\d+)\}\r\n$/) { + my $bytes = $+{bytes}; + my $read = 0; + my @lines = (); + while ($read < $bytes) { + my $line = $self->readline_block(); + $read += length($line); + push @lines, $line; + + #print "Got total of $read bytes. data = --'$data'--"; + } + my $line = $self->readline_block(); + if ($line ne ")\r\n") { + confess "Expected closing brace after data. Got: '$line'"; + } + push @lines, $line; + return \@lines; + } else { + confess "First line doesn't match FETCH pattern. Line is: '$first_line'"; + } +} + +method writeline($line) { + $log->tracef("%s >> %s", $self->{log_id}, $line =~ s/\r\n$//r); + return $self->{deps}->{sock}->writeline($line); +} + +method readline_block() { + if ($self->{line_buffer}->@* > 0) { + return $self->_readline_buffer(); + } + + my $response = $self->{deps}->{sock}->readline(); + if (defined $response) { + $log->tracef("%s << %s", $self->{log_id}, $response =~ s/\r\n$//r); + } else { + $log->tracef("%s input stream closed (read undef)", $self->{log_id}); + } + return $response; +} + +method readline_timeout() { + my $timeout = $self->{keepalive_timeout}; + + while (1) { + my $ret = timeout $timeout => sub { + return $self->readline_block(); + }; + if ($@) { + $log->debug("Keepalive timeout reached. Sending noop"); + my @noop_reply = $self->send_command("noop")->@*; + #print Dumper(\@noop_reply); + if (@noop_reply > 1) { + # last line is the reply to NOOP (send_command checks for + # that). anything else is data that likely got in between the + # timeout expiring and noop reply. it should likely be passed + # back up to our caller + pop @noop_reply; + push $self->{line_buffer}->@*, @noop_reply; + return $self->_readline_buffer(); + } + } else { + return $ret; + } + } +} + +method _readline_buffer() { + return shift $self->{line_buffer}->@*; +} +1; + +__END__ diff --git a/lib/App/ImapNotify/Notifier.pm b/lib/App/ImapNotify/Notifier.pm new file mode 100644 index 0000000..66e6fa6 --- /dev/null +++ b/lib/App/ImapNotify/Notifier.pm @@ -0,0 +1,48 @@ +package App::ImapNotify::Notifier; +use v5.24; +use strict; +use warnings; + +use Function::Parameters; + +=head1 NAME + +App::ImapNotify::Notifier - Show notification to user + +=head1 SYNOPSIS + + use App::ImapNotify::Notifier; + + my $notifier = App::ImapNotify::Notifier->new(); + $notifier->notify("subject", "body"); + +=head1 DESCRIPTION + +Uses notify-send to show a notification to the user. + +=head1 SEE ALSO + +L<App::ImapNotify> + +=cut + +method new($class: $deps = {}) { + return $class->new_no_defaults($deps); +} + +method new_no_defaults($class: $deps = {}) { + my $self = {}; + bless $self, $class; + $self->{deps} = $deps; + return $self; +} + +method notify($heading, $body) { + system(qw(notify-send -t 10000 --), $heading, $body); +} + + + +1; + +__END__ diff --git a/lib/App/ImapNotify/Socket/SSL.pm b/lib/App/ImapNotify/Socket/SSL.pm new file mode 100644 index 0000000..18d7ffa --- /dev/null +++ b/lib/App/ImapNotify/Socket/SSL.pm @@ -0,0 +1,34 @@ +package App::ImapNotify::Socket::SSL; +use v5.24; +use strict; +use warnings; + +use autodie; +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 = {}) { + my $self = {}; + bless $self, $class; + $self->{deps} = $deps; + return $self; +} + +method readline() { + return CORE::readline $self->{deps}->{sock}; +} + +method writeline($line) { + print {$self->{deps}->{sock}} $line; +} + + +1; + +__END__ diff --git a/script/imap-notify.pl b/script/imap-notify.pl new file mode 100755 index 0000000..f2f7c2c --- /dev/null +++ b/script/imap-notify.pl @@ -0,0 +1,58 @@ +#!/usr/bin/env perl + +=head1 DESCRIPTION + +Simple notification script using IMAP NOTIFY. Note that it is very simple and +implements a custom IMAP client with very limited features. Mostly a proof of +concept and personal script. + +=cut + +use v5.24; + +use warnings; +use strict; + +use App::ImapNotify; +use Function::Parameters; +use MCE::Hobo; +use Log::Any::Adapter ('Stderr', log_level => "warn"); + +my $config = [ + { + log_id => "server-speed", + host => 'mail.server-speed.net', + port => 993, + username => 'mail-flo', + password => trim(`getpw-single msmtp3`), + mailboxes => [qw(INBOX INBOX.Postmaster INBOX.TISS INBOX.tuwel)], + }, + #{ + #log_id => "luxx", + #host => 'mail.nano-srv.net', + #port => 993, + #username => 'bluewind@luxx-area.de', + #password => trim(`getpw-single bluewind\@luxx-area.de`), + #mailboxes => [qw(INBOX)], + #}, +]; + +#$IO::Socket::SSL::DEBUG = 4; + +my @workers; + +for my $single_conf ($config->@*) { + push @workers, mce_async { + my $app = App::ImapNotify->new($single_conf); + $app->loop(); + } +} + +map {$_->join()} @workers; + +fun trim($string) { + $string =~ s/^\s+//; + $string =~ s/\s+$//; + return $string; +} + diff --git a/t/00_compile.t b/t/00_compile.t index f5854a8..06f7f97 100644 --- a/t/00_compile.t +++ b/t/00_compile.t @@ -1,8 +1,12 @@ use strict; +use warnings; use Test::More 0.98; use_ok $_ for qw( App::ImapNotify + App::ImapNotify::ImapClient + App::ImapNotify::Notifier + App::ImapNotify::Socket::SSL ); done_testing; diff --git a/t/01_basic.t b/t/01_basic.t new file mode 100644 index 0000000..6f9d076 --- /dev/null +++ b/t/01_basic.t @@ -0,0 +1,58 @@ +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; + + +my $notifier = Test::MockObject->new(); +$notifier->set_true("notify"); + +my $socket = Test::MockObject->new(); +$socket->set_series('readline', + "* 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", + # this stuff should be ignored + "* 51 EXISTS\r\n", + "* 1 RECENT\r\n", + # this is a notification + "* 51 FETCH (UID 41023 BODY[HEADER.FIELDS (FROM TO SUBJECT)] {".(36+24+23+2)."}\r\n", + "From: <test\@localhost.localdomain>\r\n", + "To: <bluewind\@xinu.at>\r\n", + "Subject: Some subject\r\n", + "\r\n", + ")\r\n", +); + +$socket->set_true(qw(writeline)); + +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, notifier => $notifier}); + +$app->loop(); + +is($socket->readline(), undef, "readline queue is read fully"); + +eq_or_diff($notifier->_calls(), [ + ['notify', [$notifier, 'From: <test@localhost.localdomain>', 'Subject: Some subject']] + ], "notifier is called correctly"); + +done_testing; diff --git a/t/02_noop.t b/t/02_noop.t new file mode 100644 index 0000000..c00a3c2 --- /dev/null +++ b/t/02_noop.t @@ -0,0 +1,73 @@ +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 + +This test simulates a server that doesn't send any notifications. The client +then runs into the keepalive timeout at which point the server just happens to +receive a new message which it returns before the NOOP (keepalive) response. + +=cut + +my $notifier = Test::MockObject->new(); +$notifier->set_true("notify"); + +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", + # this sub is aborted by the timeout + sub {sleep 10; fail("Keepalive failed to kill readline() operation");}, + # notification that got in before the NOOP response + "* 51 FETCH (UID 41023 BODY[HEADER.FIELDS (FROM TO SUBJECT)] {".(36+24+23+2)."}\r\n", + "From: <test\@localhost.localdomain>\r\n", + "To: <bluewind\@xinu.at>\r\n", + "Subject: Some subject\r\n", + "\r\n", + ")\r\n", + "CMD-3 OK NOOP 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)); + +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, notifier => $notifier}); + +$app->loop(); + +is(scalar(@input_lines), 0, "all input lines are read"); + +eq_or_diff($notifier->_calls(), [ + ['notify', [$notifier, 'From: <test@localhost.localdomain>', 'Subject: Some subject']] + ], "notifier is called correctly"); + +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"]], + ], "notifier is called correctly"); + +done_testing; |