view release on metacpan or  search on metacpan

lib/Net/IMAP/Server/Connection.pm  view on Meta::CPAN

package Net::IMAP::Server::Connection;

use warnings;
use strict;

use base 'Class::Accessor';

use Coro;
use AnyEvent;
use Scalar::Util qw/weaken/;

use Net::IMAP::Server::Error;
use Net::IMAP::Server::Command;

__PACKAGE__->mk_accessors(
    qw(server coro io_handle model auth
       timer commands pending
       selected_read_only
       _selected

       temporary_messages temporary_sequence_map
       ignore_flags
       _session_flags

       last_poll previous_exists in_poll
       _unsent_expunge _unsent_fetch
       )
);

=head1 NAME

Net::IMAP::Server::Connection - Connection to a client

=head1 DESCRIPTION

Maintains all of the state for a client connection to the IMAP server.

=head1 METHODS

=head2 new

Creates a new connection; the server will take care of this step.

=cut

sub new {
    my $class = shift;
    my $self  = $class->SUPER::new(
        {   @_,
            state           => "unauth",
            _unsent_expunge => [],
            _unsent_fetch   => {},
            last_poll       => time,
            commands        => 0,
            coro            => $Coro::current,
            _session_flags  => {},
        }
    );
    $self->update_timer;
    return $self;
}

=head2 server

Returns the L<Net::IMAP::Server> that this connection is on.

=head2 coro

Returns the L<Coro> process associated with this connection.  For
things interacting with this connection, it will probably be the
current coroutine, except for interactions coming from event loops.

=head2 io_handle

Returns the IO handle that can be used to read from or write to the
client.

=head2 model

Gets or sets the L<Net::IMAP::Server::DefaultModel> or descendant
associated with this connection.  Note that connections which have not
authenticated yet do not have a model.

=head2 auth

Gets or sets the L<Net::IMAP::Server::DefaultAuth> or descendant
associated with this connection.  Note that connections which have not
authenticated yet do not have an auth object.

=cut

sub auth {
    my $self = shift;
    if (@_) {
        $self->{auth} = shift;
        $self->server->model_class->require || $self->log(1, $@);
        $self->update_timer;
        $self->model(
            $self->server->model_class->new( { auth => $self->{auth} } ) );
    }
    return $self->{auth};
}

=head2 client_id

When called with no arguments, returns a hashref of identifying
information provided by the client.  When key-value pairs are
provided, sets the client properties.  See RFC 2971.

=cut

sub client_id {
    my $self = shift;
    if (@_ > 1) {
        $self->{client} = {%{$self->{client} || {}}, @_};
    }
    return $self->{client} || {};
}

=head2 selected [MAILBOX], [READ_ONLY]

Gets or sets the currently selected mailbox for this connection.
Changing mailboxes triggers the sending of untagged notifications to
the client, as well as calling L<Net::IMAP::Server::Mailbox/close> and
L<Net::IMAP::Server::Mailbox/select>.

=cut

sub selected {
    my $self = shift;
    my ($mailbox, $read_only) = @_;

    # This is just being called as a getter
    return $self->_selected unless @_;

    # This is a setter, but isn't actually changing the mailbox, nor
    # changing the read-only-ness.
    return $self->_selected if ($mailbox || "") eq ($self->_selected || "")
        and ($self->selected_read_only || 0) == ($read_only || 0);

    # Otherwise, flush any untagged messages, close the old, and open
    # the new.
    $self->send_untagged;
    $self->_selected->close if $self->_selected;
    $self->_selected( $mailbox );
    if ($self->_selected) {
        $self->selected_read_only( $read_only );
        $self->_selected->select;
    }

    return $self->_selected;
}

=head2 selected_read_only

Returns true of the currently selected mailbox has been forced into
read-only mode.  Note that the mailbox may be read-only for other
reasons, so checking L<Net::IMAP::Server::Mailbox/read_only> is
suggested instead.

=head2 greeting

Sends out a one-line untagged greeting to the client.

=cut

sub greeting {
    my $self = shift;
    $self->untagged_response('OK IMAP4rev1 Server');
}

=head2 handle_lines

The main line handling loop.  Since we are using L<Coro>, this cedes
to other coroutines whenever we block, given them a chance to run.  We
additionally cede after handling every command.

=cut

sub handle_lines {
    my $self = shift;
    $self->coro->prio(-4);

    eval {
        $self->greeting;
        while ( $self->io_handle and $_ = $self->io_handle->getline() ) {
            $self->handle_command($_);
            $self->commands( $self->commands + 1 );
            if (    $self->is_unauth
                and $self->server->unauth_commands
                and $self->commands >= $self->server->unauth_commands )
            {
                $self->out(
                    "* BYE Don't noodle around so much before logging in!");
                last;
            }
            $self->update_timer;
            cede;
        }

        $self->log( 4,
            "-(@{[$self]},@{[$self->auth ? $self->auth->user : '???']},@{[$self->is_selected ? $self->selected->full_path : 'unselected']}): Connection closed by remote host"
        );
    };
    my $err = $@;
    $self->log(1, $err)
        if $err and not( $err eq "Error printing\n" or $err eq "Timeout\n" );
    eval { $self->out("* BYE Idle timeout; I fell asleep.") if $err eq "Timeout\n"; };
    $self->close;
}

=head2 update_timer

Updates the inactivity timer.

=cut

sub update_timer {
    my $self = shift;
    $self->timer(undef);
    my $weakself = $self;
    weaken($weakself);
    my $timeout = sub {
        $weakself->coro->throw("Timeout\n");
        $weakself->coro->ready;
    };
    if ( $self->is_unauth and $self->server->unauth_idle ) {
        $self->timer( AnyEvent->timer( after => $self->server->unauth_idle, cb => $timeout ) );
    } elsif ( $self->server->auth_idle ) {
        $self->timer( AnyEvent->timer( after => $self->server->auth_idle, cb => $timeout ) );
    }
}

=head2 timer [AnyEvent watcher]

Returns the L<AnyEvent> watcher in charge of the inactivity timer.

=head2 commands

Returns the number of client commands the connection has processed.

=head2 handle_command

Handles a single line from the client.  This is not quite the same as
handling a command, because of client literals and continuation
commands.  This also handles dispatch of client commands to
L<Net::IMAP::Server::Command> subclasses (see L</class_for>).

Any errors generated while running commands will cause a C<NO Server
error> to be sent to the client -- unless the error message starts
with C<NO> or c<BAD>, in which case it will be relayed to the client.

Returns the L<Net::IMAP::Server::Command> instance that was run, or
C<undef> if it was a continuation line or pending interactive command.

=cut

sub handle_command {
    my $self    = shift;
    my $content = shift;

    my $output = $content;
    $output =~ s/[\r\n]+$//;
    $self->log( 4,
        "C(@{[$self]},@{[$self->auth ? $self->auth->user : '???']},@{[$self->is_selected ? $self->selected->full_path : 'unselected']}): $output"
    );

    if ( $self->pending ) {
        $self->pending->($content);
        return;
    }

    my ( $id, $cmd, $options ) = $self->parse_command($content);
    return unless defined $id;

    my $handler = $self->class_for($cmd)->new(
        {   server      => $self->server,
            connection  => $self,
            options_str => $options,
            command_id  => $id,
            command     => $cmd
        }
    );
    return if $handler->has_literal;

lib/Net/IMAP/Server/Connection.pm  view on Meta::CPAN

            $handler->no_command($1);
        } elsif ($error =~ /^BAD (.*)/) {
            $handler->bad_command($1);
        } else {
            $handler->no_command("Server error");
            $self->log(1, $error);
        }
    }
    return $handler;
}

=head2 class_for COMMAND

Returns the package name that implements the given C<COMMAND>.  See
L<Net::IMAP::Server/add_command>.

=cut

sub class_for {
    my $self = shift;
    my $cmd = shift;
    my $classref = $self->server->command_class;
    my $cmd_class = $classref->{lc $cmd} || $classref->{$cmd} || $classref->{uc $cmd}
         || "Net::IMAP::Server::Command::$cmd";
    my $class_path = $cmd_class;
    $class_path =~ s{::}{/}g;

    $cmd_class->require();
    my $err = $@;
    if ($err and $err !~ /^Can't locate $class_path.pm in \@INC/) {
        $self->log(1, $@);
        $cmd_class = "Net::IMAP::Server::Error";
    }

    return $cmd_class->can('run') ? $cmd_class : "Net::IMAP::Server::Command";
}

=head2 pending

If a connection has pending state, contains the callback that will
receive the next line of input.

=cut

=head2 close

Shuts down this connection, also closing the model and mailboxes.

=cut

sub close {
    my $self = shift;
    if ( $self->io_handle ) {
        $self->io_handle->close;
        $self->io_handle(undef);
    }
    $self->timer( undef )  if $self->timer;
    $self->selected->close if $self->selected;
    $self->model->close    if $self->model;
    $self->server->connection(undef) if $self->server;
    $self->coro(undef);
}

=head2 parse_command LINE

Parses the line into the C<tag>, C<command>, and C<options>.  Returns
undef if parsing fails for some reason.

=cut

sub parse_command {
    my $self = shift;
    my $line = shift;
    $line =~ s/[\r\n]+$//;
    my $TAG = qr/([^\(\)\{ \*\%"\\\+}]+)/;
    unless ( $line =~ /^$TAG\s+(\w+)(?:\s+(.+?))?$/ ) {
        if ( $line !~ /^$TAG\s+/ ) {
            $self->out("* BAD Invalid tag");
        } else {
            $self->out("* BAD Null command ('$line')");
        }
        return undef;
    }

    my $id   = $1;
    my $cmd  = $2;
    my $args = $3 || '';
    $cmd = ucfirst( lc($cmd) );
    return ( $id, $cmd, $args );
}

=head2 is_unauth

Returns true if the connection is unauthenticated.

=cut

sub is_unauth {
    my $self = shift;
    return not defined $self->auth;
}

=head2 is_auth

Returns true if the connection is authenticated.

=cut

sub is_auth {
    my $self = shift;
    return defined $self->auth;
}

=head2 is_selected

Returns true if the connection has selected a mailbox.

=cut

sub is_selected {
    my $self = shift;