view release on metacpan or  search on metacpan

lib/API/ISPManager.pm  view on Meta::CPAN

    return %$params ? $query_path . mk_query_string($params) : '';
}


# Make request to server and get answer
# STATIC (STRING: query_string)
sub mk_query_to_server {
    my $query_string = shift;

    return '' unless $query_string;
    warn "Query string: $query_string\n" if $DEBUG;

    my $ua = LWP::UserAgent->new;
    $ua->agent("Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)");
    # Don`t working without this string!

    my $response = $ua->get($query_string);

    if ($response->is_success) {
        my $content = $response->content;

        if ($response->header('content-type') eq 'text/xml') {
            # allow only XML answers
            if ($content && $content =~ /^<\?xml version="\d\.\d" encoding="UTF-8"\?>/s) {
                warn $content if $DEBUG;
                return $content;
            } else {
                return '';
            }
        } else {
            return '';
        }
    } else {
        return '';
    }
}

# Parse answer
# STATIC(HASHREF: params)
# params:
#  STRING: answer
#  HASHREF: xml_parser_params)
sub parse_answer {
    my %params = @_;

    my $answer_string =
        $params{answer};
    my $parser_params =
        $params{parser_params} || { };

    return '' unless $answer_string;

    my $deparsed = XMLin( $answer_string, %$parser_params );
    warn Dumper $deparsed if $DEBUG;
    
    return $deparsed ? $deparsed : '';
}

# Get + deparse
# STATIC(STRING: query_string)
sub process_query {
    my %params = @_;

    my $query_string      = $params{query_string};
    my $xml_parser_params = $params{parser_params} || '';
    my $fake_answer       = $params{fake_answer} || '';

    return '' unless $query_string;

    my $answer = $fake_answer ? $fake_answer : mk_query_to_server($query_string);
    warn $answer if $answer && $DEBUG;

    return $answer ?
        parse_answer(
            answer        => $answer,
            parser_params => $xml_parser_params
        ) : '';
}

# Filter hash
# STATIC(HASHREF: hash, ARRREF: allowed_keys)
# RETURN: hashref only with allowed keys
sub filter_hash {
    my ($hash, $allowed_keys) = @_;

    return unless ref $hash eq 'HASH' &&
        ref $allowed_keys eq 'ARRAY';
    
    my $new_hash = { };

    foreach my $allowed_key (@$allowed_keys) {
        if (exists $hash->{$allowed_key}) {
            $new_hash->{$allowed_key} = $hash->{$allowed_key};
        }
    }

    return $new_hash;
}

# Get access key, time to live -- 30 minutes
# STATIC(HASHREF: params_hash)
# params_hash:
# - all elements from mk_full_query_string +
# - username*
# - password*
sub get_auth_id {
    my %params_raw = @_;

    warn 'get_auth_id params: ' . Dumper(\%params_raw)  if $DEBUG;

    my $params = filter_hash(
        \%params_raw,
        [ 'host', 'path', 'allow_http', 'username', 'password' ]
    );

    # Check this sub params
    unless ($params->{username} && $params->{password}) {
        return '';
    }

    
    my $query_string = mk_full_query_string( {
        %$params, 
        func     => 'auth',
        out      => 'xml',
    } );

    return '' unless $query_string;
    
    warn $query_string if $DEBUG;

    my $xml = process_query( query_string => $query_string);

    if ($xml) {
        my $error_node = exists $xml->{authfail};
        return '' if $error_node;

        return $xml->{auth}->{id};
    } else {
        return '';
    }
}

# Wrapper for "ref" on undef value, without warnings :)
# Possible very stupid sub :)
# STATIC(REF: our_ref)
sub refs {
    my $ref = shift;

    return '' unless $ref;

    return ref $ref;
}

# INTERNAL!!! Check server answer result
# STATIC(data_block)
sub is_success {
    my $data_block = shift;

    if ( ref $data_block eq 'HASH' && ! $data_block->{error} && $data_block->{data} ) {
        return 1;
    } else {
        return '';
    }
}

# Get data from server answer
# STATIC(data_block)
sub get_data {
    my $data_block = shift;

    unless ( is_success($data_block) ) {
        return '';
    }

    return $data_block->{data};
}

# list all users
# all params derived from get_auth_id
sub query_abstract {
    my %params = @_;

    my $params_raw  = $params{params};
    my $func_name   = $params{func};
    my $fake_answer = $params{fake_answer} || '';

    warn 'query_abstract ' . Dumper( \%params ) if $DEBUG;

    return '' unless $params_raw && $func_name; 

    my $allowed_fields = $params{allowed_fields} || [ 'host', 'path', 'allow_http' ];
    # TODO сделать сцепку массивов тут!!!!

    my $xml_parser_params = $params{parser_params};

    my $auth_id = $fake_answer  ? '112323' : get_auth_id( %$params_raw );
    warn "Auth_id: $auth_id\n" if $DEBUG;

    if ($auth_id or $func_name eq 'ftp') { # ftp hacked by authinfo
        my $params = filter_hash( $params_raw, $allowed_fields);
    
        my $query_string = mk_full_query_string( {
            ( $func_name eq 'ftp' ? ( ) : ( auth => $auth_id ) ), # for ftp auth not used, only authinfo
            func => $func_name,
            out  => 'xml',
            %$params,
        } );

        warn Dumper $query_string if $DEBUG;

        return process_query(
            query_string  => $query_string,
            parser_params => $xml_parser_params,
            fake_answer   => $fake_answer,
        );

        # 
        # TODO add this check here 
        #  if ( $server_answer && $server_answer->{elem} && ref $server_answer->{elem} eq 'HASH' ) {
        #        return { data =>  $server_answer->{elem} };
        #    }
        #

    } else {
        warn "auth_id not found or func type not ftp" if $DEBUG;
        return '';
    }
}

1;