mirror of
https://github.com/percona/percona-toolkit.git
synced 2025-09-10 13:11:32 +00:00
Almost working pt-agent main process. Clean up HTTP::Micro. Add Percona/WebAPI/Util, and some basic Percona/WebAPI/Representation tests.
This commit is contained in:
Daniel Nichter
382
bin/pt-agent
382
bin/pt-agent
@@ -24,6 +24,7 @@ BEGIN {
|
||||
Percona::WebAPI::Resource::Service
|
||||
Percona::WebAPI::Resource::Run
|
||||
Percona::WebAPI::Representation
|
||||
Percona::WebAPI::Util
|
||||
VersionCheck
|
||||
DSNParser
|
||||
OptionParser
|
||||
@@ -1233,6 +1234,39 @@ sub as_config {
|
||||
# End Percona::WebAPI::Representation package
|
||||
# ###########################################################################
|
||||
|
||||
# ###########################################################################
|
||||
# Percona::WebAPI::Util package
|
||||
# This package is a copy without comments from the original. The original
|
||||
# with comments and its test file can be found in the Bazaar repository at,
|
||||
# lib/Percona/WebAPI/Util.pm
|
||||
# t/lib/Percona/WebAPI/Util.t
|
||||
# See https://launchpad.net/percona-toolkit for more information.
|
||||
# ###########################################################################
|
||||
{
|
||||
package Percona::WebAPI::Util;
|
||||
|
||||
use Digest::MD5 qw(md5_hex);
|
||||
|
||||
use Percona::WebAPI::Representation;
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our %EXPORT_TAGS = ();
|
||||
our @EXPORT_OK = (qw(resource_diff));
|
||||
our @EXPORT = ();
|
||||
|
||||
sub resource_diff {
|
||||
my ($x, $y) = @_;
|
||||
return md5_hex(Percona::WebAPI::Representation::as_json($x))
|
||||
cmp md5_hex(Percona::WebAPI::Representation::as_json($y));
|
||||
}
|
||||
|
||||
1;
|
||||
}
|
||||
# ###########################################################################
|
||||
# End Percona::WebAPI::Util package
|
||||
# ###########################################################################
|
||||
|
||||
# ###########################################################################
|
||||
# VersionCheck package
|
||||
# This package is a copy without comments from the original. The original
|
||||
@@ -1262,7 +1296,7 @@ use constant PTDEBUG => $ENV{PTDEBUG} || 0;
|
||||
local $EVAL_ERROR;
|
||||
eval {
|
||||
require Percona::Toolkit;
|
||||
require Percona::HTTP::Micro;
|
||||
require HTTP::Micro;
|
||||
};
|
||||
|
||||
my $dir = File::Spec->tmpdir();
|
||||
@@ -1374,7 +1408,7 @@ sub pingback {
|
||||
|
||||
my ($instances, $ua, $vc) = @args{qw(instances ua VersionCheck)};
|
||||
|
||||
$ua ||= HTTPMicro->new( timeout => 5 );
|
||||
$ua ||= HTTP::Micro->new( timeout => 5 );
|
||||
$vc ||= VersionCheck->new();
|
||||
|
||||
my $response = $ua->request('GET', $url);
|
||||
@@ -4265,13 +4299,21 @@ package pt_agent;
|
||||
use strict;
|
||||
use warnings FATAL => 'all';
|
||||
use English qw(-no_match_vars);
|
||||
|
||||
use Percona::Toolkit;
|
||||
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
|
||||
|
||||
use POSIX qw(signal_h);
|
||||
use Time::HiRes qw(sleep time);
|
||||
|
||||
use Percona::Toolkit;
|
||||
use Percona::WebAPI::Client;
|
||||
use Percona::WebAPI::Exception::Request;
|
||||
use Percona::WebAPI::Resource::Agent;
|
||||
use Percona::WebAPI::Resource::Config;
|
||||
use Percona::WebAPI::Resource::Service;
|
||||
use Percona::WebAPI::Resource::Run;
|
||||
use Percona::WebAPI::Representation;
|
||||
use Percona::WebAPI::Util qw(resource_diff);
|
||||
|
||||
use sigtrap 'handler', \&sig_int, 'normal-signals';
|
||||
|
||||
my $oktorun = 1;
|
||||
@@ -4305,15 +4347,40 @@ sub main {
|
||||
# ########################################################################
|
||||
my $api_key = $o->get('api-key');
|
||||
if ( !$api_key ) {
|
||||
die "Error starting pt-agent: missing API key. pt-agent requires "
|
||||
. "a Percona Web Services API key to run. Specify your API key "
|
||||
. "in a --config file or with --api-key. Please contact Percona "
|
||||
. "if you need help. pt-agent is not running.\n";
|
||||
_err("No API key was found or specified. pt-agent requires a "
|
||||
. "Percona Web Services API key to run. Put your API key "
|
||||
. "in a --config file or specify it with --api-key.");
|
||||
}
|
||||
|
||||
# ########################################################################
|
||||
# Check the config file.
|
||||
# ########################################################################
|
||||
my $home_dir = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.';
|
||||
my $config_file = "$home_dir/.pt-agent.conf";
|
||||
if ( -f $config_file ) {
|
||||
die "$config_file is not writable.\n" unless -w $config_file;
|
||||
}
|
||||
else {
|
||||
eval {
|
||||
open my $fh, '>', $config_file
|
||||
or die "Error opening $config_file: $OS_ERROR";
|
||||
print { $fh } "api-key=$api_key\n"
|
||||
or die "Error writing to $config_file: $OS_ERROR";
|
||||
close $fh
|
||||
or die "Error closing $config_file: $OS_ERROR";
|
||||
};
|
||||
if ( $EVAL_ERROR ) {
|
||||
chomp $EVAL_ERROR;
|
||||
_err("$EVAL_ERROR. pt-agent requires write access to "
|
||||
. "$config_file to run.");
|
||||
}
|
||||
}
|
||||
|
||||
# ########################################################################
|
||||
# Run pt-agent.
|
||||
# ########################################################################
|
||||
my $daemon;
|
||||
|
||||
if ( my $service = $o->get('run-service') ) {
|
||||
run_service(
|
||||
service => $service,
|
||||
@@ -4333,7 +4400,6 @@ sub main {
|
||||
# process. Only internal errors should cause it to stop. Else,
|
||||
# external errors, like Percona web API not responding, should be
|
||||
# retried forever.
|
||||
my $daemon;
|
||||
if ( $o->get('daemonize') ) {
|
||||
$daemon = new Daemon(o=>$o);
|
||||
$daemon->daemonize();
|
||||
@@ -4344,15 +4410,54 @@ sub main {
|
||||
$daemon->make_PID_file();
|
||||
}
|
||||
|
||||
# Start or create the agent.
|
||||
init_agent(
|
||||
api_key => $api_key,
|
||||
agent_id => $o->get('agent-id'),
|
||||
check_interval => $o->get('check-interval'),
|
||||
# During initial connection and agent init, wait less time
|
||||
# than --check-interval between errors.
|
||||
# TODO: make user-configurable? --reconnect-interval?
|
||||
my $init_interval = 120;
|
||||
my $init_wait = sub {
|
||||
return unless $oktorun;
|
||||
_info("Sleeping $init_interval seconds");
|
||||
sleep $init_interval;
|
||||
};
|
||||
|
||||
# Get a connected Percona Web API client.
|
||||
my $client = get_api_client(
|
||||
api_key => $api_key,
|
||||
tries => undef,
|
||||
interval => $init_wait,
|
||||
);
|
||||
|
||||
# Start or create the agent.
|
||||
my $agent = init_agent(
|
||||
client => $client,
|
||||
interval => $init_wait,
|
||||
agent_id => $o->get('agent-id'), # optional
|
||||
);
|
||||
|
||||
# Wait time between checking for new config and services.
|
||||
# Use the tool's built-in default until a config is gotten,
|
||||
# then config->{check-interval} will be pass in.
|
||||
my $check_interval = $o->get('check-interval');
|
||||
my $check_wait = sub {
|
||||
my ($t) = @_;
|
||||
return unless $oktorun;
|
||||
$t ||= $check_interval;
|
||||
_info("Sleeping $t seconds");
|
||||
sleep $t;
|
||||
};
|
||||
|
||||
# Run the agent's main loop which doesn't return until the service
|
||||
# is stopped, killed, or has an internal bug.
|
||||
run_agent(
|
||||
agent => $agent,
|
||||
client => $client,
|
||||
interval => $check_wait,
|
||||
config_file => $config_file,
|
||||
);
|
||||
_info('Agent ' . $agent->id . ' has stopped');
|
||||
}
|
||||
|
||||
_log("pt-agent exit $exit_status, oktorun $oktorun");
|
||||
_info("pt-agent exit $exit_status, oktorun $oktorun");
|
||||
|
||||
return $exit_status;
|
||||
}
|
||||
@@ -4368,24 +4473,31 @@ sub main {
|
||||
# Create and connect a Percona Web API client.
|
||||
sub get_api_client {
|
||||
my (%args) = @_;
|
||||
|
||||
have_required_args(\%args,qw(
|
||||
api_key
|
||||
interval
|
||||
)) or die;
|
||||
my $api_key = $args{api_key};
|
||||
my $api_key = $args{api_key};
|
||||
my $interval = $args{interval};
|
||||
|
||||
# Optional args
|
||||
my $tries = $args{tries};
|
||||
my $wait = $args{wait} || 30;
|
||||
|
||||
my $client;
|
||||
while ( $oktorun && !$client && (!defined $tries || $tries--) ) {
|
||||
_info("Connecting to Percona Web Services");
|
||||
eval {
|
||||
$client = Percona::WebAPI::Client->new(
|
||||
api_key => $api_key,
|
||||
api_key => $api_key,
|
||||
);
|
||||
};
|
||||
if ( $EVAL_ERROR ) {
|
||||
sleep $wait;
|
||||
_warn($EVAL_ERROR);
|
||||
$interval->();
|
||||
}
|
||||
else {
|
||||
_info("Connected");
|
||||
}
|
||||
}
|
||||
|
||||
@@ -4396,29 +4508,24 @@ sub get_api_client {
|
||||
# Agent (main daemon) process subs #
|
||||
# ################################ #
|
||||
|
||||
# Initialize the agent: if it's new, create it, wait for a config, then run;
|
||||
# else, get lastest config, then run.
|
||||
# Initialize the agent, i.e. create and return an Agent resource.
|
||||
# If there's an agent_id, then its updated (PUT), else a new agent
|
||||
# is created (POST). Doesn't return until successful.
|
||||
sub init_agent {
|
||||
my (%args) = @_;
|
||||
|
||||
have_required_args(\%args, qw(
|
||||
api_key
|
||||
check_interval
|
||||
client
|
||||
interval
|
||||
)) or die;
|
||||
my $api_key = $args{api_key};
|
||||
my $check_interval = $args{check_interval};
|
||||
my $client = $args{client};
|
||||
my $interval = $args{interval};
|
||||
|
||||
# Optional args
|
||||
my $agent_id = $args{agent_id};
|
||||
my $client = $args{client};
|
||||
my $versions = $args{versions};
|
||||
|
||||
# Get a connected Percona Web API client.
|
||||
$client ||= get_api_client(
|
||||
api_key => $api_key,
|
||||
tries => undef,
|
||||
wait => $check_interval,
|
||||
);
|
||||
_info('Initializing agent');
|
||||
|
||||
# Do a version-check every time the agent starts. If versions
|
||||
# have changed, this can affect how services are implemented.
|
||||
@@ -4426,40 +4533,6 @@ sub init_agent {
|
||||
|
||||
# Make an Agent resource. If there's an agent_id, the existing Agent
|
||||
# is updated (PUT); else, a new agent is created (POST).
|
||||
my $agent = make_agent(
|
||||
id => $agent_id,
|
||||
client => $client,
|
||||
versions => $versions,
|
||||
check_interval => $check_interval,
|
||||
);
|
||||
|
||||
# Run the agent's main loop which doesn't return until the service
|
||||
# is stopped, killed, or has an internal bug.
|
||||
run_agent(
|
||||
agent => $agent,
|
||||
client => $client,
|
||||
check_interval => $check_interval,
|
||||
);
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
# Create a new agent and wait for a config.
|
||||
sub make_agent {
|
||||
my (%args) = @_;
|
||||
|
||||
have_required_args(\%args,qw(
|
||||
client
|
||||
versions
|
||||
check_interval
|
||||
)) or die;
|
||||
my $client = $args{client};
|
||||
my $versions = $args{versions};
|
||||
my $check_interval = $args{check_interval};
|
||||
|
||||
# Optional args
|
||||
my $agent_id = $args{agent_id};
|
||||
|
||||
my $action;
|
||||
if ( $agent_id ) {
|
||||
$action = 'put';
|
||||
@@ -4476,7 +4549,7 @@ sub make_agent {
|
||||
);
|
||||
|
||||
while ( $oktorun ) {
|
||||
_log($action eq 'put' ? "Updating agent $agent_id"
|
||||
_info($action eq 'put' ? "Updating agent $agent_id"
|
||||
: "Creating new agent $agent_id");
|
||||
eval {
|
||||
$client->$action(
|
||||
@@ -4484,128 +4557,107 @@ sub make_agent {
|
||||
content => $agent,
|
||||
);
|
||||
};
|
||||
my $e = $EVAL_ERROR;
|
||||
last if !$e; # success
|
||||
|
||||
# Try again
|
||||
_log("Error: $e");
|
||||
_log("Sleeping $check_interval seconds, then trying again");
|
||||
sleep $check_interval if $oktorun;
|
||||
if ( $EVAL_ERROR ) {
|
||||
_warn($EVAL_ERROR);
|
||||
$interval->();
|
||||
}
|
||||
else {
|
||||
_info("Initialized")
|
||||
}
|
||||
}
|
||||
|
||||
return $agent;
|
||||
}
|
||||
|
||||
# Run an existing, configured agent.
|
||||
# Run the agent, i.e. exec the main loop to check/update the config
|
||||
# and services. Doesn't return until service stopped or killed.
|
||||
sub run_agent {
|
||||
my (%args) = @_;
|
||||
|
||||
have_required_args(\%args,qw(
|
||||
agent
|
||||
client
|
||||
check_interval
|
||||
interval
|
||||
config_file
|
||||
)) or die;
|
||||
my $agent = $args{agent_id};
|
||||
my $client = $args{client};
|
||||
my $check_interval = $args{check_interval};
|
||||
my $agent = $args{agent_id};
|
||||
my $client = $args{client};
|
||||
my $interval = $args{interval};
|
||||
my $config_file = $args{config_file};
|
||||
|
||||
_log("Running agent " . $agent->id);
|
||||
_info('Running agent ' . $agent->id);
|
||||
|
||||
my $config;
|
||||
my $services;
|
||||
|
||||
while ( $oktorun ) {
|
||||
my $new_config = get_config();
|
||||
if ( resource_diff($config, $new_config) ) {
|
||||
_log('Got new config');
|
||||
eval {
|
||||
write_config();
|
||||
};
|
||||
if ( $EVAL_ERROR ) {
|
||||
}
|
||||
else {
|
||||
eval {
|
||||
_info('Getting config');
|
||||
my $new_config = $client->get(
|
||||
url => $client->links->{config},
|
||||
);
|
||||
if ( resource_diff($config, $new_config) ) {
|
||||
_info('Got new config');
|
||||
write_config(
|
||||
config => $config,
|
||||
file => $config_file,
|
||||
);
|
||||
$config = $new_config;
|
||||
}
|
||||
};
|
||||
if ( $EVAL_ERROR ) {
|
||||
_warn($EVAL_ERROR);
|
||||
}
|
||||
|
||||
my $new_services = get_services();
|
||||
if ( resource_diff($services, $new_services) ) {
|
||||
_log('Got new services');
|
||||
write_services();
|
||||
schedule_services();
|
||||
if ( $config ) {
|
||||
eval {
|
||||
_info('Getting services');
|
||||
my $new_services = $client->get(
|
||||
url => $client->links->{services},
|
||||
);
|
||||
if ( resource_diff($services, $new_services) ) {
|
||||
_info('Got new services');
|
||||
write_services();
|
||||
schedule_services();
|
||||
}
|
||||
};
|
||||
if ( $EVAL_ERROR ) {
|
||||
_warn($EVAL_ERROR);
|
||||
}
|
||||
}
|
||||
else {
|
||||
_info('Agent ' . $agent->id . ' is not configured');
|
||||
}
|
||||
|
||||
_log("Sleeping $check_interval seconds, then checking again");
|
||||
sleep $check_interval if $oktorun;
|
||||
# If no config yet, the tool's built-in default for
|
||||
# --check-interval is used instead.
|
||||
$interval->($config->{'check-interval'});
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
# Get the agent's config from Percona. There won't be a config until
|
||||
# the agent has been configured by the customer via the web app.
|
||||
sub get_config {
|
||||
# Write a Config resource to a Percona Toolkit config file,
|
||||
# usually $HOME/pt-agent.conf.
|
||||
sub write_config {
|
||||
my (%args) = @_;
|
||||
|
||||
have_required_args(\%args,qw(
|
||||
client
|
||||
check_interval
|
||||
config
|
||||
file
|
||||
)) or die;
|
||||
my $client = $args{client};
|
||||
my $check_interval = $args{client};
|
||||
my $config = $args{config};
|
||||
my $file = $args{file};
|
||||
|
||||
my $config;
|
||||
while ( $oktorun ) {
|
||||
_log('Getting config');
|
||||
eval {
|
||||
$config = $client->get(
|
||||
url => $client->links->{config},
|
||||
);
|
||||
};
|
||||
my $e = $EVAL_ERROR;
|
||||
last if !$e && $config; # success
|
||||
_info("Writing new config to $file");
|
||||
|
||||
# Try again
|
||||
if ( $e ) {
|
||||
_log("Error: $e");
|
||||
}
|
||||
elsif ( !$config ) {
|
||||
_log('No config for this agent yet.');
|
||||
}
|
||||
_log("Sleeping $check_interval seconds, then trying again");
|
||||
sleep $check_interval if $oktorun;
|
||||
}
|
||||
open my $fh, '>', $file
|
||||
or die "Error opening $file: $OS_ERROR";
|
||||
print { $fh } Percona::WebAPI::Representation::as_config($config)
|
||||
or die "Error writing to $file: $OS_ERROR";
|
||||
close $fh
|
||||
or die "Error closing $file: $OS_ERROR";
|
||||
|
||||
return $config;
|
||||
}
|
||||
|
||||
sub get_services {
|
||||
my (%args) = @_;
|
||||
have_required_args(\%args,qw(
|
||||
client
|
||||
check_interval
|
||||
)) or die;
|
||||
my $client = $args{client};
|
||||
my $check_interval = $args{client};
|
||||
|
||||
my $services;
|
||||
while ( $oktorun ) {
|
||||
_log('Getting services');
|
||||
eval {
|
||||
$services = $client->get(
|
||||
url => $client->links->{services},
|
||||
);
|
||||
};
|
||||
my $e = $EVAL_ERROR;
|
||||
last if !$e; # success
|
||||
|
||||
# Try again
|
||||
_log("Error: $e");
|
||||
_log("Sleeping $check_interval seconds, then trying again");
|
||||
sleep $check_interval if $oktorun;
|
||||
}
|
||||
|
||||
return $services;
|
||||
return;
|
||||
}
|
||||
|
||||
# #################### #
|
||||
@@ -4630,13 +4682,29 @@ sub send_data {
|
||||
# ################## #
|
||||
|
||||
sub _log {
|
||||
my ($msg) = @_;
|
||||
my ($level, $msg) = @_;
|
||||
my ($s, $m, $h, $d, $M) = localtime;
|
||||
my $ts = sprintf('%02d-%02dT%02d:%02d:%02d', $M+1, $d, $h, $m, $s);
|
||||
print "$ts $msg\n";
|
||||
print "$ts $level $msg\n";
|
||||
return;
|
||||
}
|
||||
|
||||
sub _info {
|
||||
return _log('INFO', @_);
|
||||
}
|
||||
|
||||
sub _warn {
|
||||
$exit_status |= 1;
|
||||
return _log('WARNING', @_);
|
||||
}
|
||||
|
||||
sub _err {
|
||||
my $msg = shift;
|
||||
_log('ERROR', $msg . ' Please contact Percona if you need help.');
|
||||
$exit_status |= 1;
|
||||
exit $exit_status;
|
||||
}
|
||||
|
||||
sub get_uuid {
|
||||
return '123';
|
||||
}
|
||||
|
||||
@@ -1,4 +1,4 @@
|
||||
# This program is copyright 2012 Percona Inc.
|
||||
# This program is copyright 2012-2013 Percona Inc.
|
||||
# Feedback and improvements are welcome.
|
||||
#
|
||||
# THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
|
||||
@@ -15,23 +15,21 @@
|
||||
# this program; if not, write to the Free Software Foundation, Inc., 59 Temple
|
||||
# Place, Suite 330, Boston, MA 02111-1307 USA.
|
||||
# ###########################################################################
|
||||
# HTTPMicro package
|
||||
# HTTP::Micro package
|
||||
# ###########################################################################
|
||||
{
|
||||
# Package: HTTPMicro
|
||||
# Package: HTTP::Micro
|
||||
# A stripped down version of HTTP::Tiny; but not a correct HTTP/1.1
|
||||
# implementation
|
||||
# implementation.
|
||||
package HTTP::Micro;
|
||||
|
||||
our $VERSION = '0.01';
|
||||
|
||||
package HTTPMicro;
|
||||
BEGIN {
|
||||
$HTTPMicro::VERSION = '0.001';
|
||||
}
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use warnings FATAL => 'all';
|
||||
use English qw(-no_match_vars);
|
||||
use Carp ();
|
||||
|
||||
|
||||
my @attributes;
|
||||
BEGIN {
|
||||
@attributes = qw(agent timeout);
|
||||
@@ -103,7 +101,7 @@ sub _request {
|
||||
headers => {},
|
||||
};
|
||||
|
||||
my $handle = HTTPMicro::Handle->new(timeout => $self->{timeout});
|
||||
my $handle = HTTP::Micro::Handle->new(timeout => $self->{timeout});
|
||||
|
||||
$handle->connect($scheme, $host, $port);
|
||||
|
||||
@@ -169,322 +167,327 @@ sub _split_url {
|
||||
return ($scheme, $host, $port, $path_query);
|
||||
}
|
||||
|
||||
package
|
||||
HTTPMicro::Handle; # hide from PAUSE/indexers
|
||||
use strict;
|
||||
use warnings;
|
||||
} # HTTP::Micro
|
||||
|
||||
use Carp qw[croak];
|
||||
use Errno qw[EINTR EPIPE];
|
||||
use IO::Socket qw[SOCK_STREAM];
|
||||
{
|
||||
package HTTP::Micro::Handle;
|
||||
|
||||
sub BUFSIZE () { 32768 }
|
||||
use strict;
|
||||
use warnings FATAL => 'all';
|
||||
use English qw(-no_match_vars);
|
||||
|
||||
my $Printable = sub {
|
||||
local $_ = shift;
|
||||
s/\r/\\r/g;
|
||||
s/\n/\\n/g;
|
||||
s/\t/\\t/g;
|
||||
s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;
|
||||
$_;
|
||||
};
|
||||
use Carp qw(croak);
|
||||
use Errno qw(EINTR EPIPE);
|
||||
use IO::Socket qw(SOCK_STREAM);
|
||||
|
||||
sub new {
|
||||
my ($class, %args) = @_;
|
||||
return bless {
|
||||
rbuf => '',
|
||||
timeout => 60,
|
||||
max_line_size => 16384,
|
||||
%args
|
||||
}, $class;
|
||||
}
|
||||
sub BUFSIZE () { 32768 }
|
||||
|
||||
my $ssl_verify_args = {
|
||||
check_cn => "when_only",
|
||||
wildcards_in_alt => "anywhere",
|
||||
wildcards_in_cn => "anywhere"
|
||||
};
|
||||
my $Printable = sub {
|
||||
local $_ = shift;
|
||||
s/\r/\\r/g;
|
||||
s/\n/\\n/g;
|
||||
s/\t/\\t/g;
|
||||
s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;
|
||||
$_;
|
||||
};
|
||||
|
||||
sub connect {
|
||||
@_ == 4 || croak(q/Usage: $handle->connect(scheme, host, port)/);
|
||||
my ($self, $scheme, $host, $port) = @_;
|
||||
sub new {
|
||||
my ($class, %args) = @_;
|
||||
return bless {
|
||||
rbuf => '',
|
||||
timeout => 60,
|
||||
max_line_size => 16384,
|
||||
%args
|
||||
}, $class;
|
||||
}
|
||||
|
||||
if ( $scheme eq 'https' ) {
|
||||
eval "require IO::Socket::SSL"
|
||||
unless exists $INC{'IO/Socket/SSL.pm'};
|
||||
croak(qq/IO::Socket::SSL must be installed for https support\n/)
|
||||
unless $INC{'IO/Socket/SSL.pm'};
|
||||
}
|
||||
elsif ( $scheme ne 'http' ) {
|
||||
croak(qq/Unsupported URL scheme '$scheme'\n/);
|
||||
}
|
||||
my $ssl_verify_args = {
|
||||
check_cn => "when_only",
|
||||
wildcards_in_alt => "anywhere",
|
||||
wildcards_in_cn => "anywhere"
|
||||
};
|
||||
|
||||
$self->{fh} = 'IO::Socket::INET'->new(
|
||||
PeerHost => $host,
|
||||
PeerPort => $port,
|
||||
Proto => 'tcp',
|
||||
Type => SOCK_STREAM,
|
||||
Timeout => $self->{timeout}
|
||||
) or croak(qq/Could not connect to '$host:$port': $@/);
|
||||
sub connect {
|
||||
@_ == 4 || croak(q/Usage: $handle->connect(scheme, host, port)/);
|
||||
my ($self, $scheme, $host, $port) = @_;
|
||||
|
||||
binmode($self->{fh})
|
||||
or croak(qq/Could not binmode() socket: '$!'/);
|
||||
if ( $scheme eq 'https' ) {
|
||||
eval "require IO::Socket::SSL"
|
||||
unless exists $INC{'IO/Socket/SSL.pm'};
|
||||
croak(qq/IO::Socket::SSL must be installed for https support\n/)
|
||||
unless $INC{'IO/Socket/SSL.pm'};
|
||||
}
|
||||
elsif ( $scheme ne 'http' ) {
|
||||
croak(qq/Unsupported URL scheme '$scheme'\n/);
|
||||
}
|
||||
|
||||
if ( $scheme eq 'https') {
|
||||
IO::Socket::SSL->start_SSL($self->{fh});
|
||||
ref($self->{fh}) eq 'IO::Socket::SSL'
|
||||
or die(qq/SSL connection failed for $host\n/);
|
||||
if ( $self->{fh}->can("verify_hostname") ) {
|
||||
$self->{fh}->verify_hostname( $host, $ssl_verify_args );
|
||||
}
|
||||
else {
|
||||
# Can't use $self->{fh}->verify_hostname because the IO::Socket::SSL
|
||||
# that comes from yum doesn't have it, so use our inlined version.
|
||||
my $fh = $self->{fh};
|
||||
_verify_hostname_of_cert($host, _peer_certificate($fh), $ssl_verify_args)
|
||||
or die(qq/SSL certificate not valid for $host\n/);
|
||||
}
|
||||
}
|
||||
$self->{fh} = IO::Socket::INET->new(
|
||||
PeerHost => $host,
|
||||
PeerPort => $port,
|
||||
Proto => 'tcp',
|
||||
Type => SOCK_STREAM,
|
||||
Timeout => $self->{timeout}
|
||||
) or croak(qq/Could not connect to '$host:$port': $@/);
|
||||
|
||||
$self->{host} = $host;
|
||||
$self->{port} = $port;
|
||||
binmode($self->{fh})
|
||||
or croak(qq/Could not binmode() socket: '$!'/);
|
||||
|
||||
return $self;
|
||||
}
|
||||
if ( $scheme eq 'https') {
|
||||
IO::Socket::SSL->start_SSL($self->{fh});
|
||||
ref($self->{fh}) eq 'IO::Socket::SSL'
|
||||
or die(qq/SSL connection failed for $host\n/);
|
||||
if ( $self->{fh}->can("verify_hostname") ) {
|
||||
$self->{fh}->verify_hostname( $host, $ssl_verify_args );
|
||||
}
|
||||
else {
|
||||
# Can't use $self->{fh}->verify_hostname because the IO::Socket::SSL
|
||||
# that comes from yum doesn't have it, so use our inlined version.
|
||||
my $fh = $self->{fh};
|
||||
_verify_hostname_of_cert($host, _peer_certificate($fh), $ssl_verify_args)
|
||||
or die(qq/SSL certificate not valid for $host\n/);
|
||||
}
|
||||
}
|
||||
|
||||
sub close {
|
||||
@_ == 1 || croak(q/Usage: $handle->close()/);
|
||||
my ($self) = @_;
|
||||
CORE::close($self->{fh})
|
||||
or croak(qq/Could not close socket: '$!'/);
|
||||
}
|
||||
$self->{host} = $host;
|
||||
$self->{port} = $port;
|
||||
|
||||
sub write {
|
||||
@_ == 2 || croak(q/Usage: $handle->write(buf)/);
|
||||
my ($self, $buf) = @_;
|
||||
return $self;
|
||||
}
|
||||
|
||||
my $len = length $buf;
|
||||
my $off = 0;
|
||||
sub close {
|
||||
@_ == 1 || croak(q/Usage: $handle->close()/);
|
||||
my ($self) = @_;
|
||||
CORE::close($self->{fh})
|
||||
or croak(qq/Could not close socket: '$!'/);
|
||||
}
|
||||
|
||||
local $SIG{PIPE} = 'IGNORE';
|
||||
sub write {
|
||||
@_ == 2 || croak(q/Usage: $handle->write(buf)/);
|
||||
my ($self, $buf) = @_;
|
||||
|
||||
while () {
|
||||
$self->can_write
|
||||
or croak(q/Timed out while waiting for socket to become ready for writing/);
|
||||
my $r = syswrite($self->{fh}, $buf, $len, $off);
|
||||
if (defined $r) {
|
||||
$len -= $r;
|
||||
$off += $r;
|
||||
last unless $len > 0;
|
||||
}
|
||||
elsif ($! == EPIPE) {
|
||||
croak(qq/Socket closed by remote server: $!/);
|
||||
}
|
||||
elsif ($! != EINTR) {
|
||||
croak(qq/Could not write to socket: '$!'/);
|
||||
}
|
||||
}
|
||||
return $off;
|
||||
}
|
||||
my $len = length $buf;
|
||||
my $off = 0;
|
||||
|
||||
sub read {
|
||||
@_ == 2 || @_ == 3 || croak(q/Usage: $handle->read(len)/);
|
||||
my ($self, $len) = @_;
|
||||
local $SIG{PIPE} = 'IGNORE';
|
||||
|
||||
my $buf = '';
|
||||
my $got = length $self->{rbuf};
|
||||
while () {
|
||||
$self->can_write
|
||||
or croak(q/Timed out while waiting for socket to become ready for writing/);
|
||||
my $r = syswrite($self->{fh}, $buf, $len, $off);
|
||||
if (defined $r) {
|
||||
$len -= $r;
|
||||
$off += $r;
|
||||
last unless $len > 0;
|
||||
}
|
||||
elsif ($! == EPIPE) {
|
||||
croak(qq/Socket closed by remote server: $!/);
|
||||
}
|
||||
elsif ($! != EINTR) {
|
||||
croak(qq/Could not write to socket: '$!'/);
|
||||
}
|
||||
}
|
||||
return $off;
|
||||
}
|
||||
|
||||
if ($got) {
|
||||
my $take = ($got < $len) ? $got : $len;
|
||||
$buf = substr($self->{rbuf}, 0, $take, '');
|
||||
$len -= $take;
|
||||
}
|
||||
sub read {
|
||||
@_ == 2 || @_ == 3 || croak(q/Usage: $handle->read(len)/);
|
||||
my ($self, $len) = @_;
|
||||
|
||||
while ($len > 0) {
|
||||
$self->can_read
|
||||
or croak(q/Timed out while waiting for socket to become ready for reading/);
|
||||
my $r = sysread($self->{fh}, $buf, $len, length $buf);
|
||||
if (defined $r) {
|
||||
last unless $r;
|
||||
$len -= $r;
|
||||
}
|
||||
elsif ($! != EINTR) {
|
||||
croak(qq/Could not read from socket: '$!'/);
|
||||
}
|
||||
}
|
||||
if ($len) {
|
||||
croak(q/Unexpected end of stream/);
|
||||
}
|
||||
return $buf;
|
||||
}
|
||||
my $buf = '';
|
||||
my $got = length $self->{rbuf};
|
||||
|
||||
sub readline {
|
||||
@_ == 1 || croak(q/Usage: $handle->readline()/);
|
||||
my ($self) = @_;
|
||||
if ($got) {
|
||||
my $take = ($got < $len) ? $got : $len;
|
||||
$buf = substr($self->{rbuf}, 0, $take, '');
|
||||
$len -= $take;
|
||||
}
|
||||
|
||||
while () {
|
||||
if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) {
|
||||
return $1;
|
||||
}
|
||||
$self->can_read
|
||||
or croak(q/Timed out while waiting for socket to become ready for reading/);
|
||||
my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf});
|
||||
if (defined $r) {
|
||||
last unless $r;
|
||||
}
|
||||
elsif ($! != EINTR) {
|
||||
croak(qq/Could not read from socket: '$!'/);
|
||||
}
|
||||
}
|
||||
croak(q/Unexpected end of stream while looking for line/);
|
||||
}
|
||||
while ($len > 0) {
|
||||
$self->can_read
|
||||
or croak(q/Timed out while waiting for socket to become ready for reading/);
|
||||
my $r = sysread($self->{fh}, $buf, $len, length $buf);
|
||||
if (defined $r) {
|
||||
last unless $r;
|
||||
$len -= $r;
|
||||
}
|
||||
elsif ($! != EINTR) {
|
||||
croak(qq/Could not read from socket: '$!'/);
|
||||
}
|
||||
}
|
||||
if ($len) {
|
||||
croak(q/Unexpected end of stream/);
|
||||
}
|
||||
return $buf;
|
||||
}
|
||||
|
||||
sub read_header_lines {
|
||||
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->read_header_lines([headers])/);
|
||||
my ($self, $headers) = @_;
|
||||
$headers ||= {};
|
||||
my $lines = 0;
|
||||
my $val;
|
||||
sub readline {
|
||||
@_ == 1 || croak(q/Usage: $handle->readline()/);
|
||||
my ($self) = @_;
|
||||
|
||||
while () {
|
||||
my $line = $self->readline;
|
||||
while () {
|
||||
if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) {
|
||||
return $1;
|
||||
}
|
||||
$self->can_read
|
||||
or croak(q/Timed out while waiting for socket to become ready for reading/);
|
||||
my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf});
|
||||
if (defined $r) {
|
||||
last unless $r;
|
||||
}
|
||||
elsif ($! != EINTR) {
|
||||
croak(qq/Could not read from socket: '$!'/);
|
||||
}
|
||||
}
|
||||
croak(q/Unexpected end of stream while looking for line/);
|
||||
}
|
||||
|
||||
if ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) {
|
||||
my ($field_name) = lc $1;
|
||||
$val = \($headers->{$field_name} = $2);
|
||||
}
|
||||
elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) {
|
||||
$val
|
||||
or croak(q/Unexpected header continuation line/);
|
||||
next unless length $1;
|
||||
$$val .= ' ' if length $$val;
|
||||
$$val .= $1;
|
||||
}
|
||||
elsif ($line =~ /\A \x0D?\x0A \z/x) {
|
||||
last;
|
||||
}
|
||||
else {
|
||||
croak(q/Malformed header line: / . $Printable->($line));
|
||||
}
|
||||
}
|
||||
return $headers;
|
||||
}
|
||||
sub read_header_lines {
|
||||
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->read_header_lines([headers])/);
|
||||
my ($self, $headers) = @_;
|
||||
$headers ||= {};
|
||||
my $lines = 0;
|
||||
my $val;
|
||||
|
||||
sub write_header_lines {
|
||||
(@_ == 2 && ref $_[1] eq 'HASH') || croak(q/Usage: $handle->write_header_lines(headers)/);
|
||||
my($self, $headers) = @_;
|
||||
while () {
|
||||
my $line = $self->readline;
|
||||
|
||||
my $buf = '';
|
||||
while (my ($k, $v) = each %$headers) {
|
||||
my $field_name = lc $k;
|
||||
$field_name =~ /\A [\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]+ \z/x
|
||||
or croak(q/Invalid HTTP header field name: / . $Printable->($field_name));
|
||||
$field_name =~ s/\b(\w)/\u$1/g;
|
||||
$buf .= "$field_name: $v\x0D\x0A";
|
||||
}
|
||||
$buf .= "\x0D\x0A";
|
||||
return $self->write($buf);
|
||||
}
|
||||
if ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) {
|
||||
my ($field_name) = lc $1;
|
||||
$val = \($headers->{$field_name} = $2);
|
||||
}
|
||||
elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) {
|
||||
$val
|
||||
or croak(q/Unexpected header continuation line/);
|
||||
next unless length $1;
|
||||
$$val .= ' ' if length $$val;
|
||||
$$val .= $1;
|
||||
}
|
||||
elsif ($line =~ /\A \x0D?\x0A \z/x) {
|
||||
last;
|
||||
}
|
||||
else {
|
||||
croak(q/Malformed header line: / . $Printable->($line));
|
||||
}
|
||||
}
|
||||
return $headers;
|
||||
}
|
||||
|
||||
sub read_content_body {
|
||||
@_ == 3 || @_ == 4 || croak(q/Usage: $handle->read_content_body(callback, response, [read_length])/);
|
||||
my ($self, $cb, $response, $len) = @_;
|
||||
$len ||= $response->{headers}{'content-length'};
|
||||
sub write_header_lines {
|
||||
(@_ == 2 && ref $_[1] eq 'HASH') || croak(q/Usage: $handle->write_header_lines(headers)/);
|
||||
my($self, $headers) = @_;
|
||||
|
||||
croak("No content-length in the returned response, and this "
|
||||
. "UA doesn't implement chunking") unless defined $len;
|
||||
my $buf = '';
|
||||
while (my ($k, $v) = each %$headers) {
|
||||
my $field_name = lc $k;
|
||||
$field_name =~ /\A [\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]+ \z/x
|
||||
or croak(q/Invalid HTTP header field name: / . $Printable->($field_name));
|
||||
$field_name =~ s/\b(\w)/\u$1/g;
|
||||
$buf .= "$field_name: $v\x0D\x0A";
|
||||
}
|
||||
$buf .= "\x0D\x0A";
|
||||
return $self->write($buf);
|
||||
}
|
||||
|
||||
while ($len > 0) {
|
||||
my $read = ($len > BUFSIZE) ? BUFSIZE : $len;
|
||||
$cb->($self->read($read), $response);
|
||||
$len -= $read;
|
||||
}
|
||||
sub read_content_body {
|
||||
@_ == 3 || @_ == 4 || croak(q/Usage: $handle->read_content_body(callback, response, [read_length])/);
|
||||
my ($self, $cb, $response, $len) = @_;
|
||||
$len ||= $response->{headers}{'content-length'};
|
||||
|
||||
return;
|
||||
}
|
||||
croak("No content-length in the returned response, and this "
|
||||
. "UA doesn't implement chunking") unless defined $len;
|
||||
|
||||
sub write_content_body {
|
||||
@_ == 2 || croak(q/Usage: $handle->write_content_body(request)/);
|
||||
my ($self, $request) = @_;
|
||||
my ($len, $content_length) = (0, $request->{headers}{'content-length'});
|
||||
while ($len > 0) {
|
||||
my $read = ($len > BUFSIZE) ? BUFSIZE : $len;
|
||||
$cb->($self->read($read), $response);
|
||||
$len -= $read;
|
||||
}
|
||||
|
||||
$len += $self->write($request->{content});
|
||||
return;
|
||||
}
|
||||
|
||||
$len == $content_length
|
||||
or croak(qq/Content-Length missmatch (got: $len expected: $content_length)/);
|
||||
sub write_content_body {
|
||||
@_ == 2 || croak(q/Usage: $handle->write_content_body(request)/);
|
||||
my ($self, $request) = @_;
|
||||
my ($len, $content_length) = (0, $request->{headers}{'content-length'});
|
||||
|
||||
return $len;
|
||||
}
|
||||
$len += $self->write($request->{content});
|
||||
|
||||
sub read_response_header {
|
||||
@_ == 1 || croak(q/Usage: $handle->read_response_header()/);
|
||||
my ($self) = @_;
|
||||
$len == $content_length
|
||||
or croak(qq/Content-Length missmatch (got: $len expected: $content_length)/);
|
||||
|
||||
my $line = $self->readline;
|
||||
return $len;
|
||||
}
|
||||
|
||||
$line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x
|
||||
or croak(q/Malformed Status-Line: / . $Printable->($line));
|
||||
sub read_response_header {
|
||||
@_ == 1 || croak(q/Usage: $handle->read_response_header()/);
|
||||
my ($self) = @_;
|
||||
|
||||
my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4);
|
||||
my $line = $self->readline;
|
||||
|
||||
return {
|
||||
status => $status,
|
||||
reason => $reason,
|
||||
headers => $self->read_header_lines,
|
||||
protocol => $protocol,
|
||||
};
|
||||
}
|
||||
$line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x
|
||||
or croak(q/Malformed Status-Line: / . $Printable->($line));
|
||||
|
||||
sub write_request_header {
|
||||
@_ == 4 || croak(q/Usage: $handle->write_request_header(method, request_uri, headers)/);
|
||||
my ($self, $method, $request_uri, $headers) = @_;
|
||||
my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4);
|
||||
|
||||
return $self->write("$method $request_uri HTTP/1.1\x0D\x0A")
|
||||
+ $self->write_header_lines($headers);
|
||||
}
|
||||
return {
|
||||
status => $status,
|
||||
reason => $reason,
|
||||
headers => $self->read_header_lines,
|
||||
protocol => $protocol,
|
||||
};
|
||||
}
|
||||
|
||||
sub _do_timeout {
|
||||
my ($self, $type, $timeout) = @_;
|
||||
$timeout = $self->{timeout}
|
||||
unless defined $timeout && $timeout >= 0;
|
||||
sub write_request_header {
|
||||
@_ == 4 || croak(q/Usage: $handle->write_request_header(method, request_uri, headers)/);
|
||||
my ($self, $method, $request_uri, $headers) = @_;
|
||||
|
||||
my $fd = fileno $self->{fh};
|
||||
defined $fd && $fd >= 0
|
||||
or croak(q/select(2): 'Bad file descriptor'/);
|
||||
return $self->write("$method $request_uri HTTP/1.1\x0D\x0A")
|
||||
+ $self->write_header_lines($headers);
|
||||
}
|
||||
|
||||
my $initial = time;
|
||||
my $pending = $timeout;
|
||||
my $nfound;
|
||||
sub _do_timeout {
|
||||
my ($self, $type, $timeout) = @_;
|
||||
$timeout = $self->{timeout}
|
||||
unless defined $timeout && $timeout >= 0;
|
||||
|
||||
vec(my $fdset = '', $fd, 1) = 1;
|
||||
my $fd = fileno $self->{fh};
|
||||
defined $fd && $fd >= 0
|
||||
or croak(q/select(2): 'Bad file descriptor'/);
|
||||
|
||||
while () {
|
||||
$nfound = ($type eq 'read')
|
||||
? select($fdset, undef, undef, $pending)
|
||||
: select(undef, $fdset, undef, $pending) ;
|
||||
if ($nfound == -1) {
|
||||
$! == EINTR
|
||||
or croak(qq/select(2): '$!'/);
|
||||
redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0;
|
||||
$nfound = 0;
|
||||
}
|
||||
last;
|
||||
}
|
||||
$! = 0;
|
||||
return $nfound;
|
||||
}
|
||||
my $initial = time;
|
||||
my $pending = $timeout;
|
||||
my $nfound;
|
||||
|
||||
sub can_read {
|
||||
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_read([timeout])/);
|
||||
my $self = shift;
|
||||
return $self->_do_timeout('read', @_)
|
||||
}
|
||||
vec(my $fdset = '', $fd, 1) = 1;
|
||||
|
||||
sub can_write {
|
||||
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_write([timeout])/);
|
||||
my $self = shift;
|
||||
return $self->_do_timeout('write', @_)
|
||||
}
|
||||
while () {
|
||||
$nfound = ($type eq 'read')
|
||||
? select($fdset, undef, undef, $pending)
|
||||
: select(undef, $fdset, undef, $pending) ;
|
||||
if ($nfound == -1) {
|
||||
$! == EINTR
|
||||
or croak(qq/select(2): '$!'/);
|
||||
redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0;
|
||||
$nfound = 0;
|
||||
}
|
||||
last;
|
||||
}
|
||||
$! = 0;
|
||||
return $nfound;
|
||||
}
|
||||
|
||||
sub can_read {
|
||||
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_read([timeout])/);
|
||||
my $self = shift;
|
||||
return $self->_do_timeout('read', @_)
|
||||
}
|
||||
|
||||
sub can_write {
|
||||
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_write([timeout])/);
|
||||
my $self = shift;
|
||||
return $self->_do_timeout('write', @_)
|
||||
}
|
||||
} # HTTP::Micro::Handle
|
||||
|
||||
# Partially copy-pasted from IO::Socket::SSL 1.76, with some changes because
|
||||
# we're forced to use IO::Socket::SSL version 1.01 in yum-based distros
|
||||
@@ -507,6 +510,7 @@ BEGIN {
|
||||
}
|
||||
}
|
||||
{
|
||||
use Carp qw(croak);
|
||||
my %dispatcher = (
|
||||
issuer => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_issuer_name( shift )) },
|
||||
subject => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_subject_name( shift )) },
|
||||
@@ -703,7 +707,6 @@ if ( $INC{"IO/Socket/SSL.pm"} ) {
|
||||
}
|
||||
|
||||
1;
|
||||
}
|
||||
# ###########################################################################
|
||||
# End HTTPMicro package
|
||||
# ###########################################################################
|
||||
43
lib/Percona/WebAPI/Util.pm
Normal file
43
lib/Percona/WebAPI/Util.pm
Normal file
@@ -0,0 +1,43 @@
|
||||
# This program is copyright 2012-2013 Percona Inc.
|
||||
# Feedback and improvements are welcome.
|
||||
#
|
||||
# THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
|
||||
# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
|
||||
# MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify it under
|
||||
# the terms of the GNU General Public License as published by the Free Software
|
||||
# Foundation, version 2; OR the Perl Artistic License. On UNIX and similar
|
||||
# systems, you can issue `man perlgpl' or `man perlartistic' to read these
|
||||
# licenses.
|
||||
#
|
||||
# You should have received a copy of the GNU General Public License along with
|
||||
# this program; if not, write to the Free Software Foundation, Inc., 59 Temple
|
||||
# Place, Suite 330, Boston, MA 02111-1307 USA.
|
||||
# ###########################################################################
|
||||
# Percona::WebAPI::Util package
|
||||
# ###########################################################################
|
||||
{
|
||||
package Percona::WebAPI::Util;
|
||||
|
||||
use Digest::MD5 qw(md5_hex);
|
||||
|
||||
use Percona::WebAPI::Representation;
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our %EXPORT_TAGS = ();
|
||||
our @EXPORT_OK = (qw(resource_diff));
|
||||
our @EXPORT = ();
|
||||
|
||||
sub resource_diff {
|
||||
my ($x, $y) = @_;
|
||||
return md5_hex(Percona::WebAPI::Representation::as_json($x))
|
||||
cmp md5_hex(Percona::WebAPI::Representation::as_json($y));
|
||||
}
|
||||
|
||||
1;
|
||||
}
|
||||
# ###########################################################################
|
||||
# End Percona::WebAPI::Util package
|
||||
# ###########################################################################
|
||||
@@ -40,7 +40,7 @@ use constant PTDEBUG => $ENV{PTDEBUG} || 0;
|
||||
local $EVAL_ERROR;
|
||||
eval {
|
||||
require Percona::Toolkit;
|
||||
require Percona::HTTP::Micro;
|
||||
require HTTP::Micro;
|
||||
};
|
||||
|
||||
my $dir = File::Spec->tmpdir();
|
||||
@@ -163,7 +163,7 @@ sub pingback {
|
||||
# Optional args
|
||||
my ($instances, $ua, $vc) = @args{qw(instances ua VersionCheck)};
|
||||
|
||||
$ua ||= HTTPMicro->new( timeout => 5 );
|
||||
$ua ||= HTTP::Micro->new( timeout => 5 );
|
||||
$vc ||= VersionCheck->new();
|
||||
|
||||
# GET https://upgrade.percona.com, the server will return
|
||||
|
||||
@@ -11,7 +11,7 @@ use warnings FATAL => 'all';
|
||||
use English qw(-no_match_vars);
|
||||
use Test::More;
|
||||
|
||||
use HTTPMicro;
|
||||
use HTTP::Micro;
|
||||
|
||||
local $EVAL_ERROR;
|
||||
eval { require HTTP::Tiny };
|
||||
@@ -22,12 +22,12 @@ if ( $EVAL_ERROR ) {
|
||||
# Need a simple URL that won't try to do chunking.
|
||||
for my $test_url ( "http://www.percona.com/robots.txt", "https://v.percona.com" ) {
|
||||
my $tiny = HTTP::Tiny->new(max_redirect => 0)->request('GET', $test_url);
|
||||
my $micro = HTTPMicro->new->request('GET', $test_url);
|
||||
my $micro = HTTP::Micro->new->request('GET', $test_url);
|
||||
|
||||
like(
|
||||
$micro->{content},
|
||||
qr/^\Q$tiny->{content}/,
|
||||
"HTTPMicro == HTTP::Tiny for $test_url"
|
||||
"HTTP::Micro == HTTP::Tiny for $test_url"
|
||||
);
|
||||
}
|
||||
|
||||
36
t/lib/Percona/WebAPI/Representation.t
Normal file
36
t/lib/Percona/WebAPI/Representation.t
Normal file
@@ -0,0 +1,36 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
BEGIN {
|
||||
die "The PERCONA_TOOLKIT_BRANCH environment variable is not set.\n"
|
||||
unless $ENV{PERCONA_TOOLKIT_BRANCH} && -d $ENV{PERCONA_TOOLKIT_BRANCH};
|
||||
unshift @INC, "$ENV{PERCONA_TOOLKIT_BRANCH}/lib";
|
||||
};
|
||||
|
||||
use strict;
|
||||
use warnings FATAL => 'all';
|
||||
use English qw(-no_match_vars);
|
||||
use Test::More;
|
||||
|
||||
use PerconaTest;
|
||||
use Percona::Toolkit;
|
||||
use Percona::WebAPI::Resource::Agent;
|
||||
use Percona::WebAPI::Representation;
|
||||
|
||||
my $agent = Percona::WebAPI::Resource::Agent->new(
|
||||
id => '123',
|
||||
hostname => 'pt',
|
||||
versions => {
|
||||
Perl => '5.10.1',
|
||||
},
|
||||
);
|
||||
|
||||
is(
|
||||
Percona::WebAPI::Representation::as_json($agent),
|
||||
q/{"versions":{"Perl":"5.10.1"},"id":"123","hostname":"pt"}/,
|
||||
"as_json"
|
||||
);
|
||||
|
||||
# #############################################################################
|
||||
# Done.
|
||||
# #############################################################################
|
||||
done_testing;
|
||||
50
t/lib/Percona/WebAPI/Util.t
Normal file
50
t/lib/Percona/WebAPI/Util.t
Normal file
@@ -0,0 +1,50 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
BEGIN {
|
||||
die "The PERCONA_TOOLKIT_BRANCH environment variable is not set.\n"
|
||||
unless $ENV{PERCONA_TOOLKIT_BRANCH} && -d $ENV{PERCONA_TOOLKIT_BRANCH};
|
||||
unshift @INC, "$ENV{PERCONA_TOOLKIT_BRANCH}/lib";
|
||||
};
|
||||
|
||||
use strict;
|
||||
use warnings FATAL => 'all';
|
||||
use English qw(-no_match_vars);
|
||||
use Test::More;
|
||||
|
||||
use PerconaTest;
|
||||
use Percona::Toolkit;
|
||||
use Percona::WebAPI::Resource::Config;
|
||||
use Percona::WebAPI::Util qw(resource_diff);
|
||||
|
||||
my $x = Percona::WebAPI::Resource::Config->new(
|
||||
options => {
|
||||
'lib' => '/var/lib',
|
||||
'spool' => '/var/spool',
|
||||
},
|
||||
);
|
||||
|
||||
my $y = Percona::WebAPI::Resource::Config->new(
|
||||
options => {
|
||||
'lib' => '/var/lib',
|
||||
'spool' => '/var/spool',
|
||||
},
|
||||
);
|
||||
|
||||
is(
|
||||
resource_diff($x, $y),
|
||||
0,
|
||||
"No diff"
|
||||
);
|
||||
|
||||
$y->options->{spool} = '/var/lib/spool';
|
||||
|
||||
is(
|
||||
resource_diff($x, $y),
|
||||
1,
|
||||
"Diff"
|
||||
);
|
||||
|
||||
# #############################################################################
|
||||
# Done.
|
||||
# #############################################################################
|
||||
done_testing;
|
||||
Reference in New Issue
Block a user