File Coverage

blib/lib/WWW/Yandex/MailForDomain.pm

Criterion	Covered	Total	%
statement	16	18	88.8
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	22	24	91.6

package WWW::Yandex::MailForDomain;
# coding: UTF-8

use strict;
use warnings;
use utf8;

our $VERSION = '0.2';

use LWP::UserAgent;
use URI::Escape;
use XML::Simple;

use Data::Dumper;

# ==============================================================================

use constant YANDEX_PDD_API_SERVER => 'https://pddimp.yandex.ru/';
use constant YANDEX_PDD_API_MAX_ON_PAGE => 100;

my %TRANSLATE_TO_PDD = (
    login           => 'login',
    password        => 'password',
    nickname        => 'nickname',

    enabled         => 'enabled',
    eula_signed     => 'signed_eula',

    first_name      => 'iname',
    last_name       => 'fname',
    date_of_birth   => 'birth_date',
    sex             => 'sex',

    secret_question => 'hintq',
    secret_answer   => 'hinta',

    #mail_format     => 'mail_format',
    #charset         => 'charset',
);
my %TRANSLATE_FROM_PDD = map { $TRANSLATE_TO_PDD{$_} => $_ } keys(%TRANSLATE_TO_PDD);

my %TRANSLATE_SERVER_TO_PDD = (
    protocol        => 'method',
    host            => 'ext_serv',
    port            => 'ext_port',
    no_ssl          => 'isssl',
    notify          => 'callback',
);

# ==============================================================================
# Constructor
sub new {
    my ($class, %config) = @_;
    %config = () if !(%config);

    if (! $config{token}) {
        return undef;
    }
    else {
        my $self = +{};
        $self = bless $self, ref($class) || $class;

        $self->_init(\%config);
        return $self;
    }
}
# ------------------------------------------------------------------------------
# Set up initial (passed from caller or default) values
sub _init
{
    my $self = shift;
    my ($config) = @_;

    for (qw(ua token on_error)) {
        $self->{$_} = $config->{$_};
    }

    $self->{_xs} = XML::Simple->new(
        KeepRoot        => 1,
    );

    $self->{_errmsg} = '';

    $self->{_cached_domain}     = undef;
    $self->{_cached_status}     = undef;
    $self->{_cached_total}      = undef;
    $self->{_cached_max_number} = undef;
    $self->{_cached_found}      = undef;
}
# ------------------------------------------------------------------------------
sub _throw_error {
    my ($self, $msg) = @_;

    $self->{_errmsg} = $msg;
    if ($self->{on_error}) {
        # Fire callback
        &{$self->{on_error}}($msg);
    }
}
# ------------------------------------------------------------------------------
sub error {
    my $self = shift;
    return $self->{_errmsg} || '';
}
# ------------------------------------------------------------------------------
# Produces full URI for query from sub-uri and server name
sub _uri
{
    my ($self, $cmd) = @_;
    return YANDEX_PDD_API_SERVER . $cmd . '.xml';
}
# ------------------------------------------------------------------------------
# Our User-Agent
sub _ua {
    my $self = shift;

    if (! defined($self->{ua})) {
        $self->{ua} = LWP::UserAgent->new(
            agent       => ref($self) . '/' . $VERSION,
            timeout     => 30
        );
        $self->{ua}->env_proxy;
    }

    return $self->{ua};
}
# ------------------------------------------------------------------------------
# Make request to API
sub _query
{
    my ($self, $cmd, %data) = @_;
    my $r = undef;

    if (! $self->{token}) {
        $self->_throw_error('Token is not defined');
    }
    else {

        $data{token} = $self->{token};
        my $uri = $self->_uri($cmd) . '?' .
            join('&', map { uri_escape_utf8($_) . "=" . uri_escape_utf8($data{$_}) } keys(%data));

        my $response = $self->_ua->get($uri);

        if ($response->is_success) {

            # Fix wrong encoding in header
            my $cont = $response->decoded_content;
            $cont =~ s/windows-1251/UTF-8/;

            my $xml = $self->{_xs}->XMLin($cont);

            # Error reported by API
            if (exists($xml->{page}->{error}->{reason})) {
                $self->_throw_error('PDD error: ' . $xml->{page}->{error}->{reason});
            }
            # All OK, return XML tree
            else {
                $r = $xml;
            }
        }
        else {
            $self->_throw_error('Request failed: ' . $response->status_line);
        }
    }

    return $r;
}
# ==============================================================================
#
sub _query_users
{
    my ($self, $on_page, $page_n) = @_;

    # Something wrong happens, when we set 'page' and 'on_page' parameters,
    # and number of existing mailboxes is a little.

    # Therefore, we don't set default values for undefined parameters,
    # and try to request API without 'page' and 'on_page' fields.
    # In this case, there is more chances to get a correct list of mailboxes.

    my %data = ();

    # Check $page_n
    if (! defined($page_n)) {
        #$page_n = 1;
    }
    else {
        $page_n = int($page_n);
        $page_n = 1 if $page_n < 1;
        $data{page} = $page_n;
    }

    # Check $on_page
    if (! defined($on_page)) {
        #$on_page = 1;
    }
    else {
        $on_page = int($on_page);
        if ($on_page < 1) {
            $on_page = 1;
        }
        elsif ($on_page > YANDEX_PDD_API_MAX_ON_PAGE) {
            $on_page = YANDEX_PDD_API_MAX_ON_PAGE;
        }
        $data{on_page} = $on_page;
    }

    my $r = $self->_query('get_domain_users',
        %data
    );

    # Saving some information
    if (defined($r)) {
        if ($r->{page}->{domains}->{domain}->{name}) {
            $self->{_cached_domain} = $r->{page}->{domains}->{domain}->{name};
        }

        if (exists($r->{page}->{domains}->{domain}->{status})) {
            $self->{_cached_status} = $r->{page}->{domains}->{domain}->{status};
        }

        if (exists($r->{page}->{domains}->{domain}->{'emails-max-count'})) {
            $self->{_cached_max_number} = int($r->{page}->{domains}->{domain}->{'emails-max-count'});
        }

        if (exists($r->{page}->{domains}->{domain}->{emails}->{total})) {
            $self->{_cached_total} = int($r->{page}->{domains}->{domain}->{emails}->{total});
        }

        if (exists($r->{page}->{domains}->{domain}->{emails}->{found})) {
            $self->{_cached_found} = int($r->{page}->{domains}->{domain}->{emails}->{found});
        }
    }

    return $r;
}
# ------------------------------------------------------------------------------
#
sub refresh_counters
{
    my $self = shift;

    my $r = $self->_query_users(1, 1);
    if (defined($r)) {
        $r = 1;
    }

    return $r;
}
# ------------------------------------------------------------------------------
#
sub domain
{
    my $self = shift;

    if (! $self->{_cached_domain}) {
        $self->refresh_counters;
    }

    return $self->{_cached_domain};
}
# ------------------------------------------------------------------------------
#
sub domain_status
{
    my $self = shift;

    if (! $self->{_cached_status}) {
        $self->refresh_counters;
    }

    return $self->{_cached_status};
}
# ------------------------------------------------------------------------------
#
sub users_total
{
    my $self = shift;

    if (! defined($self->{_cached_total})) {
        $self->refresh_counters;
    }

    return $self->{_cached_total};
}
# ------------------------------------------------------------------------------
#
sub users_max_number
{
    my $self = shift;

    if (! defined($self->{_cached_max_number})) {
        $self->refresh_counters;
    }

    return $self->{_cached_max_number};
}
# ------------------------------------------------------------------------------
#
sub get_users_one_page
{
    my ($self, $on_page, $page_n) = @_;

    my $r = $self->_query_users($on_page, $page_n);

    if (defined($r)) {
        if ($r->{page}->{domains}->{domain}->{emails}->{email}) {
            my @boxes = ();

            my $h = $r->{page}->{domains}->{domain}->{emails}->{email};

            # I could not tune the XML::Simple to properly parse emails list,
            # so I applied some untidy logic: get x->{email}->{name} value,
            # if we have only one item

            my @found = keys(%$h);

            if (scalar(@found) == 1) {
                push(@boxes, $h->{name});
            }
            elsif (scalar(@found) > 1) {
                push(@boxes, @found);
            }

            $r = \@boxes;
        }
        else {
            $r = +[];
        }
    }

    return $r;
}
# ------------------------------------------------------------------------------
#
sub get_users
{
    my ($self) = @_;

    # Initially, we try to get list without any parameters
    my $r = $self->get_users_one_page();

    if ($r) {
        # Collect into hash to avoid duplicates. They may occur with
        # annoying Yandex PDD paging process.
        my %boxes = ();
        for (@$r) { $boxes{$_} = 1 }

        my $found = scalar(keys(%boxes));

        if ($found < $self->users_total) {
            # Not complete, needed page by page retrieving

            my $on_page = YANDEX_PDD_API_MAX_ON_PAGE;
            my $start_page = 1;

            if ($found == YANDEX_PDD_API_MAX_ON_PAGE) {
                # First page is filled wholly
                $start_page = 2;
            }
            else {
                # First page is not filled, try again from beginning
                %boxes = ();
                $start_page = 1;
            }

            my $total_pages = int(($self->users_total + YANDEX_PDD_API_MAX_ON_PAGE - 1) / $on_page);
            my $was_error = 0;
            for (my $page_n = $start_page; $page_n <= $total_pages; $page_n++) {

                my $cur = $self->get_users_one_page($on_page, $page_n);

                if (! defined($cur)) {
                    # Something happens
                    $was_error = 1;
                    last;
                }
                else {
                    for (@$cur) { $boxes{$_} = 1 }
                }
            }

            if ($was_error) {
                $r = undef;
            }
            else {
                my @b = keys(%boxes);
                $r = \@b;
            }
        }
        else {
            # Found all by first query
            my @b = keys(%boxes);
            $r = \@b;
        }
    }

    return $r;
}
# ==============================================================================
#
sub check_user
{
    my ($self, $login) = @_;

    my $r = $self->_query('check_user',
        login     => $login,
    );

    if (defined($r) and defined($r->{page}->{result})) {
        my $x = $r->{page}->{result} eq 'exists' ? 1 : 0;
        $r = $x;
    }

    return $r;
}
# ------------------------------------------------------------------------------
#
sub add_user
{
    my ($self, $login, $password) = @_;

    my $r = $self->_query('reg_user_token',
        u_login     => $login,
        u_password  => $password,
    );

    if (defined($r)) {
        $r = $r->{page}->{ok}->{uid} || '';
        $self->refresh_counters; # Don't care about retval
    }

    return $r;
}
# ------------------------------------------------------------------------------
#
sub add_user_encrypted
{
    my ($self, $login, $password) = @_;

    my $r = $self->_query('reg_user_crypto',
        login     => $login,
        password  => $password,
    );

    if (defined($r)) {
        $r = $r->{page}->{ok}->{uid} || '';
        $self->refresh_counters; # Don't care about retval
    }

    return $r;
}
# ------------------------------------------------------------------------------
#
sub delete_user
{
    my ($self, $login) = @_;

    my $r = $self->_query('delete_user',
        login     => $login,
    );

    if (defined($r)) {
        $r = exists($r->{page}->{ok}) ? 1 : undef;
        $self->refresh_counters; # Don't care about retval
    }

    return $r;
}
# ------------------------------------------------------------------------------
#
sub change_password
{
    my ($self, $login, $new_password) = @_;

    my $r = $self->_query('edit_user',
        login     => $login,
        password  => $new_password,
    );

    if (defined($r)) {
        $r = $r->{page}->{ok}->{uid} || '';
    }

    return $r;
}
# ------------------------------------------------------------------------------
#
sub modify_user
{
    my ($self, $login, %data) = @_;

    my %q = ();
    for (qw(first_name last_name sex secret_question secret_answer)) {
        $q{$_} = $data{$_} if defined($data{$_});
    }

    # Field 'sex' must be integer in [0..2] interval
    if (exists($q{sex})) {
        $q{sex} =~ s/\D//g;
        $q{sex} = int($q{sex});
        if (($q{sex} < 0) or ($q{sex} > 2)) {
            delete $q{sex};
        }
    }

    # Translate field names
    my %qt = ();
    for (keys(%q)) {
        $qt{$TRANSLATE_TO_PDD{$_}} = $q{$_};
    }

    print Dumper(\%qt);

    # Execute query
    my $r = $self->_query('edit_user',
        login     => $login,
        %qt
    );

    if (defined($r)) {
        $r = $r->{page}->{ok}->{uid} || '';
    }

    return $r;
}
# ------------------------------------------------------------------------------
#
sub get_user_info
{
    my ($self, $login, %data) = @_;

    my $r = $self->_query('get_user_info',
        login     => $login,
    );

    if (defined($r) and defined($r->{page}->{domain}->{user})) {

        print Dumper($r), "\n\n";

        my $info = $r->{page}->{domain}->{user};
        my $u = +{};

        for my $k (keys(%$info)) {
            if (exists($TRANSLATE_FROM_PDD{$k})) {
                my $key = $TRANSLATE_FROM_PDD{$k};
                my $val = ref($info->{$k}) eq 'HASH' ? undef : $info->{$k};
                $u->{$key} = $val;
            }
        }

        $r = $u;
    }

    return $r;
}
# ------------------------------------------------------------------------------
#
sub get_unread_count
{
    my ($self, $login) = @_;

    my $r = $self->_query('get_mail_info',
        login     => $login,
    );

    if (defined($r)) {
        $r = $r->{page}->{ok}->{new_messages} || 0;
    }

    return $r;
}
# ==============================================================================
#
sub register_source
{
    my ($self, %opt) = @_;
    my $r = undef;

    if ($opt{host}) {

        $opt{protocol} = ($opt{protocol} && (lc($opt{protocol}) eq 'imap')) ? 'imap' : 'pop3';
        $opt{port} = int($opt{port}) if defined $opt{port};
        $opt{no_ssl} = $opt{no_ssl} ? 'no' : undef;

        my %q = ();
        for (keys(%opt)) {
            $q{$TRANSLATE_SERVER_TO_PDD{$_}} = $opt{$_} if defined($opt{$_});
        }

        $r = $self->_query('set_domain', %q);

        if (defined($r)) {
            $r = exists($r->{page}->{ok}) ? 1 : undef;
        }
    }
    else {
        $self->_throw_error('Remote host is not defined');
    }

    return $r;
}
# ------------------------------------------------------------------------------
#
sub start_import
{
    my ($self, $login, %data) = @_;

    my %q = ();

    $q{login}     = $login;
    $q{ext_login} = $data{remote_login}    if defined $data{remote_login};
    $q{password}  = $data{remote_password} if defined $data{remote_password};

    my $r = $self->_query('start_import', %q);

    if (defined($r)) {
        $r = exists($r->{page}->{ok}) ? 1 : undef;
    }

    return $r;
}
# ------------------------------------------------------------------------------
#
sub stop_import
{
    my ($self, $login) = @_;

    my $r = $self->_query('stop_import',
        login     => $login,
    );

    if (defined($r)) {
        $r = exists($r->{page}->{ok}) ? 1 : undef;
    }

    return $r;
}
# ------------------------------------------------------------------------------
#
sub check_import_status
{
    my ($self, $login) = @_;

    my $r = $self->_query('check_import',
        login     => $login,
    );

    if (defined($r)) {
        my $u = +{};
        $u->{time}  = $r->{page}->{ok}->{last_check};
        $u->{state} = $r->{page}->{ok}->{state};
        $r = $u;
    }

    return $r;
}
# ==============================================================================
#
sub set_forwarding
{
    my ($self, $from, $to, $dont_keep) = @_;

    my $copy = $dont_keep ? 'no' : 'yes';

    my $r = $self->_query('set_forward',
        login     => $from,
        address   => $to,
        copy      => $copy,
    );

    if (defined($r)) {
        $r = exists($r->{page}->{ok}) ? 1 : undef;
    }

    return $r;
}
# ==============================================================================
1;
__END__