File Coverage

blib/lib/Net/YAR.pm

Criterion	Covered	Total	%
statement	66	389	16.9
branch	8	208	3.8
condition	5	109	4.5
subroutine	22	68	32.3
pod	20	31	64.5
total	121	805	15.0

package Net::YAR;

=head1 NAME

Net::YAR - Perl interface to the YAR (Yet Another Registrar) API

=cut

use strict;
use Carp qw(croak confess);
use LWP::UserAgent;
use HTTP::Request;
use HTTP::Headers;
use vars qw(
    $AUTOLOAD
    $VERSION
    $JSON_ENCODE
    $JSON_DECODE
    $DEFAULT_RETRY_MAX
    $DEFAULT_RETRY_INTERVAL
);

$VERSION = sprintf "%d.%03d", q$Revision: 1.83 $ =~ /(\d+)/g;
$DEFAULT_RETRY_MAX = 3; # Retry up to this many times when network problems occur.
$DEFAULT_RETRY_INTERVAL = 15; # Seconds to wait after response failure before trying again.

sub new {
    my $class = shift;
    my $args  = shift || {};
    return bless {%$args}, $class;
}

sub api_user { my $self = shift; $self->{'api_user'} || $self->{'user'} || croak "Missing api_user" }
sub api_pass { my $self = shift; $self->{'api_pass'} || $self->{'pass'} || croak "Missing api_pass" }
sub api_host { my $self = shift; $self->{'api_host'} || $self->{'host'} || croak "Missing api_host" }
sub api_port { my $self = shift; $self->{'api_port'} || $self->{'port'} || ($self->use_ssl ? 443 : 80) }
sub api_path { my $self = shift; $self->{'api_path'} || $self->{'path'} || '/cgi/yar' }
sub use_ssl  { my $self = shift; $self->{'use_ssl'}  || $self->{'ssl'}  || 1 }
sub ssl_verify_hostname { shift->{'ssl_verify_hostname'} || 0 }
sub log_obj   {
    my $self = shift;
    if (! $self->{'log_obj'}) {
        if (my $file = $self->log_file) {
            require IO::File;
            if (my $io = new IO::File ">>$file") {
                $io->autoflush(1);
                $self->{'log_obj'} = $io;
            }
        }
    }
    return $self->{'log_obj'};
}
sub log_file { shift->{'log_file'} || undef }


sub serialize_type {
    return shift->{'serialize_type'} ||=
          eval { require JSON }            ? 'json'
        : eval { require YAML::Syck }      ? 'yaml'
        : eval { require YAML }            ? 'yaml'
        : eval { require XML::Simple }     ? 'xml'
        : eval { require Data::URIEncode } ? 'uri'
        : die "Can't find a module that can encode and decode (need one of JSON, YAML::Syck, YAML, Data::URIEncode, XML::Simple)";
}

###----------------------------------------------------------------###

sub play_method {
    my ($self, $meth, $args) = @_;
    $args ||= {};

    ### get connection details - these die if not initialized in new
    my $user = $self->api_user;
    my $pass = $self->api_pass;
    my $host = $self->api_host;
    my $port = $self->api_port;
    my $path = $self->api_path;

    ### setup the request
    local $args->{'method'} = $meth;
    die "Invalid method $meth" if $meth !~ /^[\w\.-]+$/;
    my $request = eval { $self->serialize_request($args) };
    if (! $request) {
        return Net::YAR::Fault->new({
            type            => 'serialize_error',
            method          => $meth,
            serialize_error => $@,
            serialize_args  => $args,
        });
    }

    ### send the request
    my $resp;
    my $proto = $self->use_ssl ? 'https' : 'http';
    my $url   = "$proto://$host:$port$path/$meth";
    my @head;
    if (! $args->{'authentication'}) {
        my $auth = "$user/$pass";
        $auth =~ s|([^\w.\-\:/])|sprintf('%%%02X', ord $1)|eg;
        push @head, (Cookie => "authentication=$auth;");
    }

    eval {
        my $req = HTTP::Request->new('POST', $url, HTTP::Headers->new(@head), $request);
        #warn $req->as_string;

        my $log_obj = $self->log_obj;
        if ($log_obj) {
            my $id = $args->{'domain'} || $args->{'contact_id'} || $args->{'user_id'} || "";
            $id = join ", ", @$id if ref($id) eq 'ARRAY';
            $log_obj->print(scalar(localtime).": REQUEST: $meth - $id\n",$request,"\n");
        }

        my $lwp_args = ref($args->{'lwp_args'}) eq 'HASH' ? $args->{'lwp_args'} : ref($args->{'lwp_args'}) eq 'ARRAY' ? {@{$args->{'lwp_args'}}} : {};
        local $lwp_args->{'ssl_opts'} = {} if ! $lwp_args->{'ssl_opts'};
        local $lwp_args->{'ssl_opts'}->{'verify_hostname'} = $self->ssl_verify_hostname if ! exists $lwp_args->{'ssl_opts'}->{'verify_hostname'};
        my $retries = defined $args->{'retry_max'}      ? $args->{'retry_max'}      : $DEFAULT_RETRY_MAX;
        my $interval= defined $args->{'retry_interval'} ? $args->{'retry_interval'} : $DEFAULT_RETRY_INTERVAL;
        $interval = 5 if $interval < 5;
        while (1) {
            $resp = LWP::UserAgent->new(%$lwp_args)->request($req);
            last if $resp && $resp->is_success;
            if ($retries-->0) {
                if ($log_obj) {
                    $log_obj->print(scalar(localtime).": FAILED RESPONSE (".(eval { $resp->code }).") with $retries retries left:\n".(eval { $resp->content })."\n\n");
                }
                sleep $interval;
                next;
            }
            last;
        }

        if ($log_obj) {
            $log_obj->print(scalar(localtime).": RESPONSE (".(eval { $resp->code })."):\n".(eval { $resp->content })."\n\n");
        }
    };
    if (! $resp || ! $resp->is_success) {
        return Net::YAR::Fault->new({
            type            => 'request_error',
            method          => $meth,
            request         => $request,
            request_url     => $url,
            request_error   => $@,
            request_code    => ($resp ? $resp->code : ''),
            request_message => ($resp ? $resp->message : ''),
        });
    }

    ### parse the result
    return $self->parse_response({
        method   => $meth,
        content  => $resp->content,
        response => $resp,
        request  => $request,
    });

}

sub serialize_request {
    my ($self, $args) = @_;

    ### what type of data serialization should we use
    my $type = $args->{'serialize'} || $args->{'serialize_type'} || $self->serialize_type;

    ### prepare the request
    my $request;
    if ($type eq 'yaml') {
        if (eval { require YAML::Syck }) {
            $request = YAML::Syck::Dump({request => $args});
        } else {
            require YAML;
            $request = YAML::Dump({request => $args});
        }
    } elsif ($type eq 'json') {
        require JSON;
        $JSON_ENCODE ||= JSON->VERSION > 1.98 ? 'encode' : 'objToJSon';
        if ($JSON_ENCODE eq 'encode') {
            $request = JSON->new->encode({request => $args});
        } else {
            $request = JSON->new->objToJSon({request => $args}, {autoconv => 0});
        }

    } elsif ($type eq 'xml') {
        require XML::Simple;
        $request = XML::Simple::XMLout({request => $args},
                                       XMLDecl       => 1,
                                       KeepRoot      => 1,
                                       KeyAttr       => [],
                                       NoAttr        => 1,
                                       SuppressEmpty => undef,
                                       GroupTags     => {
                                           nameservers        => 'nameserver',
                                           nameservers_add    => 'nameserver_add',
                                           nameservers_remove => 'nameserver_remove',
                                           where              => 'item',
                                           select             => 'item',
                                           group_by           => 'item',
                                           order_by           => 'item',
                                           fields             => 'field',
                                       });

    } elsif ($type eq 'uri') {
        require Data::URIEncode;
        $request = Data::URIEncode::complex_to_query({request => $args});

    } else {
        confess "Not sure how to encode or decode that type ($type)";
    }

    return $request;
}

sub parse_response {
    my ($self, $args) = @_;

    my $content = $args->{'content'};

    my $response;
    eval {
        my $data;
        if (!$content) {
            $data = { response => { type => "error", error => { code => "empty"} } };
        } elsif ($content =~ /\A \s* <\?xml /sx) {
            require XML::Simple;
            my $hash = XML::Simple::XMLin($content,
                                          SuppressEmpty => '',
                                          KeyAttr       => [],
                                          NoAttr        => 1,
                                          GroupTags     => {
                                              nameservers => 'nameserver',
                                              rows        => 'row',
                                              tlds        => 'tld',
                                              fields      => 'field',
                                          });
            foreach (qw(nameservers rows tlds)) {
                next if ! $hash->{'data'} || ! $hash->{'data'}->{$_} || ref $hash->{'data'}->{$_} ne 'HASH';
                $hash->{'data'}->{$_} = [$hash->{'data'}->{$_}];
            }
            $data = {response => $hash};

        } elsif ($content =~ /\A \s* \{ /sx) {
            require JSON;
            $JSON_DECODE ||= JSON->VERSION > 1.98 ? 'decode' : 'jsonToObj';
            local $JSON::UnMapping = 1;
            $data = JSON->new->$JSON_DECODE($content);

        } elsif ($content =~ /\A ---\s+ /sx) {
            if (eval {require YAML::Syck}) {
                $data = (YAML::Syck::Load($content))[0];
            } else {
                require YAML;
                $data = (YAML::Load($content))[0];
            }

        } elsif ($content =~ /\A [\w\.]+= /sx) {
            eval {
                require Data::URIEncode;
            } or do {
                require Carp;
                require Data::Dumper;
                Carp::confess(Data::Dumper::Dumper([$args, error => $@]));
            };
            $data = Data::URIEncode::query_to_complex($content);
        } else {
            die 'unknown_serialization';
        }

        $response = $data->{'response'} || confess "Invalid response";
    };

    ### store for later
    my $obj_args = $response || {
        type        => 'parse_error',
        parse_error => $@,
    };
    $obj_args->{'request'}  = $args->{'request'};
    $obj_args->{'response'} = $content;
    $obj_args->{'method'}   = $args->{'method'};

    ### return the appropriate object
    if (! $obj_args->{'type'} || $obj_args->{'type'} eq 'error' || $obj_args->{'type'} eq 'parse_error') {
        return Net::YAR::Fault->new($obj_args);
    } else {
        return Net::YAR::Response->new($obj_args);
    }
}

###----------------------------------------------------------------###
### dynamically handle all of the available YAR namespaces and methods

sub DESTROY {}

sub AUTOLOAD {
    my $self = shift;

    my $method = $AUTOLOAD =~ /::([\w.]+)$/ ? $1 : '';

    ### magically add _all capability to all searches
    if ($method =~ /^(\w+_search)_all$/) {
        return $self->_all_search($1, @_);

    }
    ### magically add _iter capability to all searches
    elsif ($method =~ /^(\w+_search)_iter$/) {
        return $self->_iter_search($1, @_);

    }
    ### handle all $yar->domain_register style commands
    elsif ($method =~ /^ (domain|contact|user|util|[^\W_]+) _+ (\w+) $/x) {
        my $yar_method = "$1.$2";
        my $failovers = eval {
            my $fails = $_[0]->{'failover'} or die "No failover";
            my $mod = ucfirst($1).ucfirst($2);
            require "Net/YAR/$mod.pm";
            if (my $default = UNIVERSAL::can("Net::YAR::$mod","lwp_args_yar_default")) {
                $_[0]->{'lwp_args'} ||= $default->();
            }
            $fails = [$fails] if "ARRAY" ne ref $fails;
            my @code_refs = ();
            foreach my $try (@$fails) {
                if (my $code = UNIVERSAL::can("Net::YAR::$mod",$method."_$try")) {
                    push @code_refs, $code;
                }
            }
            return \@code_refs if @code_refs;
            die "Net::Server::$mod - Unable to locate any failover for @$fails";
        };

        my $resp;
        if (eval { $resp = $self->play_method($yar_method, @_); 1 }) {
            if (!$resp) {
                # Normal YAR request failed.
                if ($failovers) {
                    # Try Net::Yar::$mod->method_$try for each failover
                    foreach my $code (@$failovers) {
                        if (my $new_resp = eval { $code->($self, $resp, @_) }) {
                            $resp = $new_resp;
                            last;
                        }
                        else { warn "FAILOVER CRASHED: $@"; }
                    }
                }
                $@ = "";
            }
            $@ = $resp if ! $resp;
            return $resp;
        }

        ### handle the yar errors
        my $err = $@;
        die $err if ! UNIVERSAL::can($err, 'type') || $err->type ne 'invalid_method';
    }

    ### die with normal invalid method error
    my $pkg = ref $self;
    croak "Can't locate object method \"$method\" via package \"$pkg\"";
}

###----------------------------------------------------------------###
### use the standard YAR API search method's pagination features
### to return all results for a given search

sub _all_search {
    my ($self, $meth, $args) = @_;

    my $N_ROWS = $args->{'rows_per_page'} || 10000;
    my $ROWS   = [];
    my $RESP   = Net::YAR::Response->new({method => "${meth}_all", type => 'success', data => {rows => $ROWS}});
    my $begin  = time;

    if (my $UNIQ_KEY = lc($args->{'unique_key'} || '')) {
        my %UNIQ;
        my $PAGE    = 1;
        my $N_EXTRA = 10;

        ### if we have a unique key - use extra_rows to allow for adds and deletes during the query
        while (1) {
            local $args->{'page'}          = $PAGE;
            local $args->{'rows_per_page'} = $N_ROWS;
            local $args->{'extra_rows'}    = $N_EXTRA;
            local $args->{'return_sql'};

            ### get the current page
            $RESP->data->{'n_requests'}++;
            my $resp = $self->$meth($args);
            if (! $resp) { # as soon as we get an error - return it
                $resp->data->{'rows'} = $RESP->data->{'rows'};
                return $resp;
            }

            my $_rows = $resp->data->{'rows'};
            my $i     = 0;
            my $found = 0;
            foreach my $row (@$_rows) {
                return Net::YAR::Fault->new({
                    method   => "${meth}_all",
                    type     => 'error',
                    code     => 'invalid_key',
                    key      => $UNIQ_KEY,
                    response => $resp,
                }) if ! exists $row->{$UNIQ_KEY};

                if (! $UNIQ{$row->{$UNIQ_KEY}}++) {
                    push @$ROWS, $row; # not found yet - add it
                } else {
                    $found++ if ++$i < $N_EXTRA;
                }
            }

            ### allow for us to modify what there is left to query
            if ($PAGE == 1) {
                $RESP->data->{'rows_per_page'}    = $resp->data->{'rows_per_page'};
                $RESP->data->{'n_rows_estimated'} = $resp->data->{'n_rows'};
                $RESP->{'request'}                = $resp->{'request'};
                $RESP->{'response'}               = "--discarded--\n";
            }

            if (@$_rows && ! $found && $PAGE > 1) { # didn't find any of the extra records - go back one page
                $PAGE -= 1;
                next;
            } elsif (@$_rows > $N_ROWS) { # had extra rows - loop to the next page
                $PAGE += 1;
                next;
            } else { # all done
                $RESP->data->{'n_pages'} = $PAGE;
                $RESP->data->{'n_rows'}  = @$ROWS;
                last;
            }
        }
    } else {
        my $PAGE    = 0;
        my $N_PAGES = 1;
        while (++$PAGE <= $N_PAGES) {
            local $args->{'page'}          = $PAGE;
            local $args->{'rows_per_page'} = $N_ROWS;
            local $args->{'extra_rows'};
            local $args->{'return_sql'};

            ### get the current page
            $RESP->data->{'n_requests'}++;
            my $resp = $self->$meth($args);
            if (! $resp) { # as soon as we get an error - return it
                $resp->data->{'rows'} = $RESP->data->{'rows'};
                return $resp;
            }

            push @$ROWS, @{ $resp->data->{'rows'} };

            ### allow for us to modify what there is left to query
            if ($PAGE == 1) {
                $N_ROWS = $RESP->data->{'rows_per_page'} = $resp->data->{'rows_per_page'} || return Net::YAR::Fault->new({
                    method   => "${meth}_all",
                    type     => 'error',
                    code     => 'missing_rows_per_page',
                    response => $resp,
                });
                $N_PAGES = $RESP->data->{'n_pages'} = $resp->data->{'n_pages'} || 0;
                $RESP->data->{'n_rows_estimated'} = $resp->data->{'n_rows'};
                $RESP->{'request'}  = $resp->{'request'};
                $RESP->{'response'} = "--discarded--\n";
            }
        }
        $RESP->data->{'n_rows'} = @$ROWS;
    }
    $RESP->data->{'elapsed'} = time - $begin;

    return $RESP;
}

###----------------------------------------------------------------###
### use the standard YAR API search method's pagination features to
### obtain all results for a given search one iteration at a time

sub _iter_search {
    my ($self, $meth, $args) = @_;

    $args->{'rows_per_page'} ||= 10_000;
    $args->{'page'}          ||= 1;
    $args->{'extra_rows'}    ||= 10;
    if (!$args->{'unique_key'}) {
        if (my $o = $args->{'order_by'}) {
            $o = [ $o ] unless ref $o eq "ARRAY";
            foreach my $field (@$o) {
                if ($field =~ /^(\w+)$/) {
                    $args->{'unique_key'} = $1;
                    last;
                }
            }
        }
    }
    croak "Arg [unique_key] could not be determined for ITER [$meth]" if !$args->{'unique_key'};
    my $response = $self->$meth($args);
    return $response if !$response;
    my %uniq = ();
    my $tie_obj = undef;
    eval {
        require DB_File;
        require Fcntl;
        my $unique_hash_file = $args->{'unique_hash_file'} || "/tmp/iter_[$args->{'unique_key'}]_$$.db";
        $tie_obj = tie(%uniq, "DB_File", $unique_hash_file, Fcntl::O_RDWR()|Fcntl::O_CREAT(), 0666) or die "$unique_hash_file: tie: $!";
        # Anonymous file backend so it will disappear once the process dies
        # but it's actually still on disk instead of wasting precious memory.
        unlink $unique_hash_file;
    } or warn "DB_File anonymous file tie failed: $@";
    my $iter = {
        %$response,
        yar      => $self,
        request  => $args,
        response => $response,
        method   => $meth."_iter",
        curr     => 0,
        i        => 0,
        tie_obj  => $tie_obj,
        uniq     => \%uniq,
    };
    return bless $iter, "Net::YAR::Iter";
}


###----------------------------------------------------------------###
### provide older shortcuts for common util operations

sub noop {        shift->play_method('util.noop',    @_) }
sub balance {     shift->play_method('util.balance', @_) }

###----------------------------------------------------------------###
### allow for $yar->util->noop type method calls

sub contact      { shift->new_chain_proxy('contact'     ) }
sub csr          { shift->new_chain_proxy('csr'         ) }
sub domain       { shift->new_chain_proxy('domain'      ) }
sub domainchange { shift->new_chain_proxy('domainchange') }
sub invoice      { shift->new_chain_proxy('invoice'     ) }
sub offer        { shift->new_chain_proxy('offer'       ) }
sub order        { shift->new_chain_proxy('order'       ) }
sub package      { shift->new_chain_proxy('package'     ) }
sub service      { shift->new_chain_proxy('service'     ) }
sub user         { shift->new_chain_proxy('user'        ) }
sub util         { shift->new_chain_proxy('util'        ) }
sub whois        { shift->new_chain_proxy('whois'       ) }
sub host         { shift->new_chain_proxy('host'        ) }
sub dns          { shift->new_chain_proxy('dns'         ) }

sub new_chain_proxy {
    my ($self, $type) = @_;
    return Net::YAR::_ChainProxy->new({yar => $self, type => $type});
}

{
    package Net::YAR::_ChainProxy;

    use strict;
    use Carp qw(croak confess);
    use vars qw($AUTOLOAD);

    sub new {
        my $class = shift || __PACKAGE__;
        my $args  = shift || {};
        croak "Missing yar" if ! $args->{'yar'};
        croak "Missing or invalid type" if ! $args->{'type'} || $args->{'type'} !~ /^\w+$/;
        return bless $args, $class;
    }

    sub DESTROY {}

    sub AUTOLOAD {
        my $self = shift;

        my $yar    = $self->{'yar'}  || croak __PACKAGE__." object modified since new - missing yar";
        my $type   = $self->{'type'} || croak __PACKAGE__." object modified since new - missing type";

        my $method = $AUTOLOAD =~ /::(\w+)$/ ? $1 : '';

        my $yar_method = $type .'_'. $method;

        return $yar->$yar_method(@_);
    }
}

###----------------------------------------------------------------###
### All returns from a YAR call should be wrapped in a Net::YAR::Response

{
    package Net::YAR::Response;

    use strict;
    use Carp qw(croak confess);
    use overload
        'bool'   => sub { ! shift->is_fault },
        '""'     => \&as_string,
        fallback => 1;

    sub new {
        my $class = shift || confess "Missing class";
        my $args  = shift || confess "Missing args";
        my $self = bless {%$args}, $class;
        $self->{'data'} ||= {};
        return $self;
    }

    sub type           { shift->{'type'}     || 'undefined' }
    sub code           { shift->{'code'}     || ''          }
    sub time           { shift->{'time'}     || ''          }
    sub data           { shift->{'data'}     || {}          }
    sub method         { shift->{'method'}   || 'unknown'   }
    sub request        { shift->{'request'}  || ''          }
    sub response       { shift->{'response'} || ''          }
    sub as_string {
        my $self  = shift;
        return ref($self) ." ". ($self->type eq 'error' ? $self->code : $self->type) ." (called with method ".$self->method.")";
    }
    sub is_fault { 0 }
}

{
    package Net::YAR::Fault;

    use strict;
    use base qw(Net::YAR::Response);

    sub is_fault { 1 }
}

{
    package Net::YAR::Iter;

    use strict;
    use Carp qw(croak confess);
    use base qw(Net::YAR::Response);

    sub next {
        my $self = shift;

        my $response = $self->response;
        if ($self->{'i'} < scalar @{ $response->data->{'rows'} }) {
            # Still more entries left since last query
            # so just return the next one in line.
            $self->{'curr'}++;
            my $result = $response->data->{'rows'}->[$self->{'i'}++];
            my $key = $self->request->{'unique_key'};
            return Net::YAR::Fault->new({
                method   => $self->method,
                type     => 'error',
                code     => 'invalid_key',
                key      => $key,
                response => $response,
            }) if ! exists $result->{$key};
            $result->{$key} = "" if !defined $result->{$key};
            if ($self->{'uniq'}->{$result->{$key}}) {
                $self->{'curr'}--;
                return $self->next;
            }
            $self->{'uniq'}->{$result->{$key}} = 1;
            return $result;
        }

        if ($self->{'i'} >= $self->data->{'rows_per_page'}) {
            # Hit the end of this page, but there is probably more, so query the next page
            $self->{'i'} = 0;
            $self->request->{'page'}++;
            my $meth = $self->method;
            $response = $self->{response} = $self->{'yar'}->$meth($self->request);
            if ($response) {
                # Recursive call
                return $self->next;
            }
            # Return whatever the failure is.
            return $response;
        }

        # Exhausted all rows
        return Net::YAR::Fault->new({
            method   => $self->method,
            type     => 'eos',
            code     => 'eos',
            key      => 'key',
            response => "--discarded--\n",
        });
    }

}

###----------------------------------------------------------------###

1;

__END__