diff options
Diffstat (limited to 'lib/App/ImapNotify/ImapClient.pm')
| -rw-r--r-- | lib/App/ImapNotify/ImapClient.pm | 214 |
1 files changed, 214 insertions, 0 deletions
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__ |