File Coverage

blib/lib/Net/IMAP/Server.pm

Criterion	Covered	Total	%
statement	9	9	100.0
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	12	12	100.0

package Net::IMAP::Server;

use warnings;
use strict;

use base qw/Net::Server::Coro Class::Accessor/;

use UNIVERSAL::require;
use Coro;
use 5.008_008;

our $VERSION = '1.39';

=head1 NAME

Net::IMAP::Server - A single-threaded multiplexing IMAP server
implementation, using L.

=head1 SYNOPSIS

  use Net::IMAP::Server;
  Net::IMAP::Server->new(
      port        => 193,
      ssl_port    => 993,
      auth_class  => "Your::Auth::Class",
      model_class => "Your::Model::Class",
      user        => "nobody",
      group       => "nobody",
  )->run;

=head1 DESCRIPTION

This model provides a complete implementation of the C
specification, along with several IMAP4rev1 extensions.  It provides
separation of the mailbox and message store from the client
interaction loop.

Note that, following RFC suggestions, login is not allowed except
under either SSL or TLS.  Thus, you are required to have a F
directory under the current working directory, containing files
F and C.  Failure to do so will cause
the server to fail to start.  Note that if the default paths suit your
needs, you can specify different ones using the L and
L arguments to L.

=head1 INTERFACE

The primary method of using this module is to supply your own model
and auth classes, which inherit from
L and
L.  This allows you to back your
messages from arbitrary data sources, or provide your own
authorization backend.  For the most part, the implementation of the
IMAP components should be opaque.

=head1 METHODS

=cut

__PACKAGE__->mk_accessors(
    qw/port ssl_port
       auth_class model_class connection_class
       command_class
       poll_every
       unauth_idle auth_idle unauth_commands
      /
);

=head2 new PARAMHASH

Creates a new IMAP server object.  This doesn't even bind to the
sockets; it merely initializes the object.  It will C if it
cannot find the appropriate certificate files.  Valid arguments to
C include:

=over

=item port

The port to bind to.  Defaults to port 1430.

=item ssl_port

The port to open an SSL listener on; by default, this is disabled, and
any true value enables it.

=item auth_class

The name of the class which implements authentication.  This must be a
subclass of L.

=item model_class

The name of the class which implements the model backend.  This must
be a subclass of L.

=item connection_class

On rare occasions, you may wish to subclass the connection class; this
class must be a subclass of L.

=item poll_every

How often the current mailbox should be polled, in seconds; defaults
to 0, which means it will be polled after every client command.

=item unauth_commands

The number of commands before unauthenticated users are disconnected.
The default is 10; set to zero to disable.

=item unauth_idle

How long, in seconds, to wait before disconnecting idle connections
which have not authenticated yet.  The default is 5 minutes; set to
zero to disable (which is not advised).

=item auth_idle

How long, in seconds, to wait before disconnecting authenticated
connections.  By RFC specification, this B be longer than 30
minutes.  The default is an hour; set to zero to disable.

=item server_cert

Path to the SSL certificate that the server should use.  This can be
either a relative or absolute path.

=item server_key

Path to the SSL certificate key that the server should use.  This can
be either a relative or absolute path.

=back

It also accepts the following L arguments -- see its
documentation for details on their use.

=over

=item L

=item L

=item L

=item L

=item L

=item L

=item L

=item L

=item L

=item L

=item L

=item L

=item L

=item L

=item L

=back

=cut

sub new {
    my $class = shift;

    my $self = Class::Accessor::new(
        $class,
        {   port             => 1430,
            ssl_port         => 0,
            auth_class       => "Net::IMAP::Server::DefaultAuth",
            model_class      => "Net::IMAP::Server::DefaultModel",
            connection_class => "Net::IMAP::Server::Connection",
            poll_every       => 0,
            unauth_idle      => 5*60,
            auth_idle        => 60*60,
            unauth_commands  => 10,
            @_,
            command_class    => {},
            connection       => {},
        }
    );

    $self->{server}{$_} = $self->{$_}
        for grep {defined $self->{$_}}
            qw/log_level log_file
               syslog_logsock syslog_ident syslog_logopt syslog_facility
               pid_file chroot user group
               reverse_lookups allow deny cidr_allow cidr_deny
              /;

    UNIVERSAL::require( $self->auth_class )
        or die "Can't require auth class: $@\n";
    $self->auth_class->isa("Net::IMAP::Server::DefaultAuth")
        or die
        "Auth class (@{[$self->auth_class]}) doesn't inherit from Net::IMAP::Server::DefaultAuth\n";

    UNIVERSAL::require( $self->model_class )
        or die "Can't require model class: $@\n";
    $self->model_class->isa("Net::IMAP::Server::DefaultModel")
        or die
        "Model class (@{[$self->model_class]}) doesn't inherit from Net::IMAP::Server::DefaultModel\n";

    UNIVERSAL::require( $self->connection_class )
        or die "Can't require connection class: $@\n";
    $self->connection_class->isa("Net::IMAP::Server::Connection")
        or die
        "Connection class (@{[$self->connection_class]}) doesn't inherit from Net::IMAP::Server::Connection\n";

    return $self;
}

=head2 run

Starts the server; this method shouldn't be expected to return.
Within this method, C<$Net::IMAP::Server::Server> is set to the object
that this was called on; thus, all IMAP objects have a way of
referring to the server -- and though L, whatever parts
of the IMAP internals they need.

Any arguments are passed through to L.

=cut

sub run {
    my $self  = shift;
    my @proto = qw/TCP/;
    my @port  = $self->port;
    if ( $self->ssl_port ) {
        push @proto, "SSL";
        push @port,  $self->ssl_port;
    }
    local $Net::IMAP::Server::Server = $self;
    $self->SUPER::run(
        @_,
        proto => \@proto,
        port  => \@port,
    );
}

=head2 process_request

Accepts a client connection; this method is needed for the
L infrastructure.

=cut

sub process_request {
    my $self   = shift;
    my $handle = $self->{server}{client};
    my $conn   = $self->connection_class->new(
        io_handle => $handle,
        server    => $self,
    );
    $self->connection($conn);
    $conn->handle_lines;
}

=head2 DESTROY

On destruction, ensure that we close all client connections and
listening sockets.

=cut

DESTROY {
    my $self = shift;
    $_->close for grep { defined $_ } @{ $self->connections };
    $self->server_close;
}

=head2 connections

Returns an arrayref of L objects which
are currently connected to the server.

=cut

sub connections {
    my $self = shift;
    return [ values %{$self->{connection}} ];
}

=head2 connection

Returns the currently active L object,
if there is one.  This is determined by examining the current
coroutine.

=cut

sub connection {
    my $class = shift;
    my $self  = ref $class ? $class : $Net::IMAP::Server::Server;
    if (@_) {
        if (defined $_[0]) {
            $self->{connection}{$Coro::current . ""} = shift;
        } else {
            delete $self->{connection}{$Coro::current . ""};
        }
    }
    return $self->{connection}{$Coro::current . ""};
}

=head2 concurrent_mailbox_connections [MAILBOX]

This can be called as either a class method or an instance method; it
returns the set of connections which are concurrently connected to the
given mailbox object (which defaults to the current connection's
selected mailbox)

=cut

sub concurrent_mailbox_connections {
    my $class    = shift;
    my $self     = ref $class ? $class : $Net::IMAP::Server::Server;
    my $selected = shift || $self->connection->selected;

    return () unless $selected;
    return
        grep { $_->is_auth and $_->is_selected and $_->selected eq $selected }
        @{ $self->connections };
}

=head2 concurrent_user_connections [USER]

This can be called as either a class method or an instance method; it
returns the set of connections whose
L is the same as the given
L (which defaults to the current connection's user)

=cut

sub concurrent_user_connections {
    my $class = shift;
    my $self  = ref $class ? $class : $Net::IMAP::Server::Server;
    my $user  = shift || $self->connection->auth->user;

    return () unless $user;
    return
        grep { $_->is_auth and $_->auth->user eq $user }
        @{ $self->connections };
}

=head2 capability

Returns the C string for the server.  This string my be
modified by the connection before being sent to the client (see
L).

=cut

sub capability {
    my $self = shift;
    return "IMAP4rev1 STARTTLS CHILDREN LITERAL+ UIDPLUS ID NAMESPACE";
}

=head2 id

Returns a hash of properties to be conveyed to the client, should they
ask the server's identity.

=cut

sub id {
    return (
        name    => "Net-IMAP-Server",
        version => $Net::IMAP::Server::VERSION,
    );
}

=head2 add_command NAME => PACKAGE

Adds the given command C to the server's list of known commands.
C should be the name of a class which inherits from
L.

=cut

sub add_command {
    my $self = shift;
    my ($name, $package) = @_;
    if (not $package->require) {
        $self->log( 1, $@ );
    } elsif (not $package->isa('Net::IMAP::Server::Command')) {
        $self->log( 1, "$package is not a Net::IMAP::Server::Command!" );
    } else {
        $self->command_class->{uc $name} = $package;
    }
}

=head2 log SEVERITY, MESSAGE

By default, defers to L, which outputs to syslog, a
logfile, or STDERR, depending how it was configured.  L's
default is to print to STDERR.  If you have custom logging needs,
override this method, or L.

=cut

1;    # Magic true value required at end of module
__END__