percona/percona-toolkit
1
0
Fork 0
mirror of https://github.com/percona/percona-toolkit.git synced 2025-09-11 13:40:07 +00:00
Code Issues Packages Projects Releases Wiki Activity

Almost working pt-agent main process. Clean up HTTP::Micro. Add Percona/WebAPI/Util, and some basic Percona/WebAPI/Representation tests.

Browse Source
This commit is contained in:
Daniel Nichter
2012-12-25 16:51:18 -07:00
parent 6f2d543653
commit 9241c27b7c
7 changed files with 643 additions and 443 deletions
Download Patch File Download Diff File Expand all files Collapse all files

364
bin/pt-agent
View File

@@ -24,6 +24,7 @@ BEGIN {
Percona::WebAPI::Resource::Service Percona::WebAPI::Resource::Service
Percona::WebAPI::Resource::Run Percona::WebAPI::Resource::Run
Percona::WebAPI::Representation Percona::WebAPI::Representation
Percona::WebAPI::Util
VersionCheck VersionCheck
DSNParser DSNParser
OptionParser OptionParser
@@ -1233,6 +1234,39 @@ sub as_config {
# End Percona::WebAPI::Representation package # 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 # VersionCheck package
# This package is a copy without comments from the original. The original # 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; local $EVAL_ERROR;
eval { eval {
require Percona::Toolkit; require Percona::Toolkit;
require Percona::HTTP::Micro; require HTTP::Micro;
}; };
my $dir = File::Spec->tmpdir(); my $dir = File::Spec->tmpdir();
@@ -1374,7 +1408,7 @@ sub pingback {
my ($instances, $ua, $vc) = @args{qw(instances ua VersionCheck)}; my ($instances, $ua, $vc) = @args{qw(instances ua VersionCheck)};
$ua ||= HTTPMicro->new( timeout => 5 ); $ua ||= HTTP::Micro->new( timeout => 5 );
$vc ||= VersionCheck->new(); $vc ||= VersionCheck->new();
my $response = $ua->request('GET', $url); my $response = $ua->request('GET', $url);
@@ -4265,13 +4299,21 @@ package pt_agent;
use strict; use strict;
use warnings FATAL => 'all'; use warnings FATAL => 'all';
use English qw(-no_match_vars); use English qw(-no_match_vars);
use Percona::Toolkit;
use constant PTDEBUG => $ENV{PTDEBUG} || 0; use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use POSIX qw(signal_h); use POSIX qw(signal_h);
use Time::HiRes qw(sleep time); 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'; use sigtrap 'handler', \&sig_int, 'normal-signals';
my $oktorun = 1; my $oktorun = 1;
@@ -4305,15 +4347,40 @@ sub main {
# ######################################################################## # ########################################################################
my $api_key = $o->get('api-key'); my $api_key = $o->get('api-key');
if ( !$api_key ) { if ( !$api_key ) {
die "Error starting pt-agent: missing API key. pt-agent requires " _err("No API key was found or specified. pt-agent requires a "
. "a Percona Web Services API key to run. Specify your API key " . "Percona Web Services API key to run. Put your API key "
. "in a --config file or with --api-key. Please contact Percona " . "in a --config file or specify it with --api-key.");
. "if you need help. pt-agent is not running.\n"; }
# ########################################################################
# 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. # Run pt-agent.
# ######################################################################## # ########################################################################
my $daemon;
if ( my $service = $o->get('run-service') ) { if ( my $service = $o->get('run-service') ) {
run_service( run_service(
service => $service, service => $service,
@@ -4333,7 +4400,6 @@ sub main {
# process. Only internal errors should cause it to stop. Else, # process. Only internal errors should cause it to stop. Else,
# external errors, like Percona web API not responding, should be # external errors, like Percona web API not responding, should be
# retried forever. # retried forever.
my $daemon;
if ( $o->get('daemonize') ) { if ( $o->get('daemonize') ) {
$daemon = new Daemon(o=>$o); $daemon = new Daemon(o=>$o);
$daemon->daemonize(); $daemon->daemonize();
@@ -4344,15 +4410,54 @@ sub main {
$daemon->make_PID_file(); $daemon->make_PID_file();
} }
# Start or create the agent. # During initial connection and agent init, wait less time
init_agent( # 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, api_key => $api_key,
agent_id => $o->get('agent-id'), tries => undef,
check_interval => $o->get('check-interval'), 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; return $exit_status;
} }
@@ -4368,24 +4473,31 @@ sub main {
# Create and connect a Percona Web API client. # Create and connect a Percona Web API client.
sub get_api_client { sub get_api_client {
my (%args) = @_; my (%args) = @_;
have_required_args(\%args,qw( have_required_args(\%args,qw(
api_key api_key
interval
)) or die; )) or die;
my $api_key = $args{api_key}; my $api_key = $args{api_key};
my $interval = $args{interval};
# Optional args # Optional args
my $tries = $args{tries}; my $tries = $args{tries};
my $wait = $args{wait} || 30;
my $client; my $client;
while ( $oktorun && !$client && (!defined $tries || $tries--) ) { while ( $oktorun && !$client && (!defined $tries || $tries--) ) {
_info("Connecting to Percona Web Services");
eval { eval {
$client = Percona::WebAPI::Client->new( $client = Percona::WebAPI::Client->new(
api_key => $api_key, api_key => $api_key,
); );
}; };
if ( $EVAL_ERROR ) { 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 # # Agent (main daemon) process subs #
# ################################ # # ################################ #
# Initialize the agent: if it's new, create it, wait for a config, then run; # Initialize the agent, i.e. create and return an Agent resource.
# else, get lastest config, then run. # 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 { sub init_agent {
my (%args) = @_; my (%args) = @_;
have_required_args(\%args, qw( have_required_args(\%args, qw(
api_key client
check_interval interval
)) or die; )) or die;
my $api_key = $args{api_key}; my $client = $args{client};
my $check_interval = $args{check_interval}; my $interval = $args{interval};
# Optional args # Optional args
my $agent_id = $args{agent_id}; my $agent_id = $args{agent_id};
my $client = $args{client};
my $versions = $args{versions}; my $versions = $args{versions};
# Get a connected Percona Web API client. _info('Initializing agent');
$client ||= get_api_client(
api_key => $api_key,
tries => undef,
wait => $check_interval,
);
# Do a version-check every time the agent starts. If versions # Do a version-check every time the agent starts. If versions
# have changed, this can affect how services are implemented. # 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 # Make an Agent resource. If there's an agent_id, the existing Agent
# is updated (PUT); else, a new agent is created (POST). # 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; my $action;
if ( $agent_id ) { if ( $agent_id ) {
$action = 'put'; $action = 'put';
@@ -4476,7 +4549,7 @@ sub make_agent {
); );
while ( $oktorun ) { while ( $oktorun ) {
_log($action eq 'put' ? "Updating agent $agent_id" _info($action eq 'put' ? "Updating agent $agent_id"
: "Creating new agent $agent_id"); : "Creating new agent $agent_id");
eval { eval {
$client->$action( $client->$action(
@@ -4484,128 +4557,107 @@ sub make_agent {
content => $agent, content => $agent,
); );
}; };
my $e = $EVAL_ERROR; if ( $EVAL_ERROR ) {
last if !$e; # success _warn($EVAL_ERROR);
$interval->();
# Try again }
_log("Error: $e"); else {
_log("Sleeping $check_interval seconds, then trying again"); _info("Initialized")
sleep $check_interval if $oktorun; }
} }
return $agent; 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 { sub run_agent {
my (%args) = @_; my (%args) = @_;
have_required_args(\%args,qw( have_required_args(\%args,qw(
agent agent
client client
check_interval interval
config_file
)) or die; )) or die;
my $agent = $args{agent_id}; my $agent = $args{agent_id};
my $client = $args{client}; my $client = $args{client};
my $check_interval = $args{check_interval}; my $interval = $args{interval};
my $config_file = $args{config_file};
_log("Running agent " . $agent->id); _info('Running agent ' . $agent->id);
my $config; my $config;
my $services; my $services;
while ( $oktorun ) { while ( $oktorun ) {
my $new_config = get_config();
if ( resource_diff($config, $new_config) ) {
_log('Got new config');
eval { eval {
write_config(); _info('Getting config');
}; my $new_config = $client->get(
if ( $EVAL_ERROR ) { url => $client->links->{config},
} );
else { if ( resource_diff($config, $new_config) ) {
_info('Got new config');
write_config(
config => $config,
file => $config_file,
);
$config = $new_config; $config = $new_config;
} }
};
if ( $EVAL_ERROR ) {
_warn($EVAL_ERROR);
} }
my $new_services = get_services(); if ( $config ) {
eval {
_info('Getting services');
my $new_services = $client->get(
url => $client->links->{services},
);
if ( resource_diff($services, $new_services) ) { if ( resource_diff($services, $new_services) ) {
_log('Got new services'); _info('Got new services');
write_services(); write_services();
schedule_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"); # If no config yet, the tool's built-in default for
sleep $check_interval if $oktorun; # --check-interval is used instead.
$interval->($config->{'check-interval'});
} }
return; return;
} }
# Write a Config resource to a Percona Toolkit config file,
# Get the agent's config from Percona. There won't be a config until # usually $HOME/pt-agent.conf.
# the agent has been configured by the customer via the web app. sub write_config {
sub get_config {
my (%args) = @_; my (%args) = @_;
have_required_args(\%args,qw( have_required_args(\%args,qw(
client config
check_interval file
)) or die; )) or die;
my $client = $args{client}; my $config = $args{config};
my $check_interval = $args{client}; my $file = $args{file};
my $config; _info("Writing new config to $file");
while ( $oktorun ) {
_log('Getting config');
eval {
$config = $client->get(
url => $client->links->{config},
);
};
my $e = $EVAL_ERROR;
last if !$e && $config; # success
# Try again open my $fh, '>', $file
if ( $e ) { or die "Error opening $file: $OS_ERROR";
_log("Error: $e"); print { $fh } Percona::WebAPI::Representation::as_config($config)
} or die "Error writing to $file: $OS_ERROR";
elsif ( !$config ) { close $fh
_log('No config for this agent yet.'); or die "Error closing $file: $OS_ERROR";
}
_log("Sleeping $check_interval seconds, then trying again");
sleep $check_interval if $oktorun;
}
return $config; return;
}
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;
} }
# #################### # # #################### #
@@ -4630,13 +4682,29 @@ sub send_data {
# ################## # # ################## #
sub _log { sub _log {
my ($msg) = @_; my ($level, $msg) = @_;
my ($s, $m, $h, $d, $M) = localtime; my ($s, $m, $h, $d, $M) = localtime;
my $ts = sprintf('%02d-%02dT%02d:%02d:%02d', $M+1, $d, $h, $m, $s); my $ts = sprintf('%02d-%02dT%02d:%02d:%02d', $M+1, $d, $h, $m, $s);
print "$ts $msg\n"; print "$ts $level $msg\n";
return; 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 { sub get_uuid {
return '123'; return '123';
} }

115
lib/HTTP/Mirco.pm → lib/HTTP/Micro.pm
View File

@@ -1,4 +1,4 @@
# This program is copyright 2012 Percona Inc. # This program is copyright 2012-2013 Percona Inc.
# Feedback and improvements are welcome. # Feedback and improvements are welcome.
# #
# THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # 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 # this program; if not, write to the Free Software Foundation, Inc., 59 Temple
# Place, Suite 330, Boston, MA 02111-1307 USA. # 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 # 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 strict;
use warnings; use warnings FATAL => 'all';
use English qw(-no_match_vars);
use Carp (); use Carp ();
my @attributes; my @attributes;
BEGIN { BEGIN {
@attributes = qw(agent timeout); @attributes = qw(agent timeout);
@@ -103,7 +101,7 @@ sub _request {
headers => {}, headers => {},
}; };
my $handle = HTTPMicro::Handle->new(timeout => $self->{timeout}); my $handle = HTTP::Micro::Handle->new(timeout => $self->{timeout});
$handle->connect($scheme, $host, $port); $handle->connect($scheme, $host, $port);
@@ -169,27 +167,31 @@ sub _split_url {
return ($scheme, $host, $port, $path_query); return ($scheme, $host, $port, $path_query);
} }
package } # HTTP::Micro
HTTPMicro::Handle; # hide from PAUSE/indexers
use strict;
use warnings;
use Carp qw[croak]; {
use Errno qw[EINTR EPIPE]; package HTTP::Micro::Handle;
use IO::Socket qw[SOCK_STREAM];
sub BUFSIZE () { 32768 } use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
my $Printable = sub { use Carp qw(croak);
use Errno qw(EINTR EPIPE);
use IO::Socket qw(SOCK_STREAM);
sub BUFSIZE () { 32768 }
my $Printable = sub {
local $_ = shift; local $_ = shift;
s/\r/\\r/g; s/\r/\\r/g;
s/\n/\\n/g; s/\n/\\n/g;
s/\t/\\t/g; s/\t/\\t/g;
s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge; s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;
$_; $_;
}; };
sub new { sub new {
my ($class, %args) = @_; my ($class, %args) = @_;
return bless { return bless {
rbuf => '', rbuf => '',
@@ -197,15 +199,15 @@ sub new {
max_line_size => 16384, max_line_size => 16384,
%args %args
}, $class; }, $class;
} }
my $ssl_verify_args = { my $ssl_verify_args = {
check_cn => "when_only", check_cn => "when_only",
wildcards_in_alt => "anywhere", wildcards_in_alt => "anywhere",
wildcards_in_cn => "anywhere" wildcards_in_cn => "anywhere"
}; };
sub connect { sub connect {
@_ == 4 || croak(q/Usage: $handle->connect(scheme, host, port)/); @_ == 4 || croak(q/Usage: $handle->connect(scheme, host, port)/);
my ($self, $scheme, $host, $port) = @_; my ($self, $scheme, $host, $port) = @_;
@@ -219,7 +221,7 @@ sub connect {
croak(qq/Unsupported URL scheme '$scheme'\n/); croak(qq/Unsupported URL scheme '$scheme'\n/);
} }
$self->{fh} = 'IO::Socket::INET'->new( $self->{fh} = IO::Socket::INET->new(
PeerHost => $host, PeerHost => $host,
PeerPort => $port, PeerPort => $port,
Proto => 'tcp', Proto => 'tcp',
@@ -250,16 +252,16 @@ sub connect {
$self->{port} = $port; $self->{port} = $port;
return $self; return $self;
} }
sub close { sub close {
@_ == 1 || croak(q/Usage: $handle->close()/); @_ == 1 || croak(q/Usage: $handle->close()/);
my ($self) = @_; my ($self) = @_;
CORE::close($self->{fh}) CORE::close($self->{fh})
or croak(qq/Could not close socket: '$!'/); or croak(qq/Could not close socket: '$!'/);
} }
sub write { sub write {
@_ == 2 || croak(q/Usage: $handle->write(buf)/); @_ == 2 || croak(q/Usage: $handle->write(buf)/);
my ($self, $buf) = @_; my ($self, $buf) = @_;
@@ -285,9 +287,9 @@ sub write {
} }
} }
return $off; return $off;
} }
sub read { sub read {
@_ == 2 || @_ == 3 || croak(q/Usage: $handle->read(len)/); @_ == 2 || @_ == 3 || croak(q/Usage: $handle->read(len)/);
my ($self, $len) = @_; my ($self, $len) = @_;
@@ -316,9 +318,9 @@ sub read {
croak(q/Unexpected end of stream/); croak(q/Unexpected end of stream/);
} }
return $buf; return $buf;
} }
sub readline { sub readline {
@_ == 1 || croak(q/Usage: $handle->readline()/); @_ == 1 || croak(q/Usage: $handle->readline()/);
my ($self) = @_; my ($self) = @_;
@@ -337,9 +339,9 @@ sub readline {
} }
} }
croak(q/Unexpected end of stream while looking for line/); croak(q/Unexpected end of stream while looking for line/);
} }
sub read_header_lines { sub read_header_lines {
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->read_header_lines([headers])/); @_ == 1 || @_ == 2 || croak(q/Usage: $handle->read_header_lines([headers])/);
my ($self, $headers) = @_; my ($self, $headers) = @_;
$headers ||= {}; $headers ||= {};
@@ -368,9 +370,9 @@ sub read_header_lines {
} }
} }
return $headers; return $headers;
} }
sub write_header_lines { sub write_header_lines {
(@_ == 2 && ref $_[1] eq 'HASH') || croak(q/Usage: $handle->write_header_lines(headers)/); (@_ == 2 && ref $_[1] eq 'HASH') || croak(q/Usage: $handle->write_header_lines(headers)/);
my($self, $headers) = @_; my($self, $headers) = @_;
@@ -384,9 +386,9 @@ sub write_header_lines {
} }
$buf .= "\x0D\x0A"; $buf .= "\x0D\x0A";
return $self->write($buf); return $self->write($buf);
} }
sub read_content_body { sub read_content_body {
@_ == 3 || @_ == 4 || croak(q/Usage: $handle->read_content_body(callback, response, [read_length])/); @_ == 3 || @_ == 4 || croak(q/Usage: $handle->read_content_body(callback, response, [read_length])/);
my ($self, $cb, $response, $len) = @_; my ($self, $cb, $response, $len) = @_;
$len ||= $response->{headers}{'content-length'}; $len ||= $response->{headers}{'content-length'};
@@ -401,9 +403,9 @@ sub read_content_body {
} }
return; return;
} }
sub write_content_body { sub write_content_body {
@_ == 2 || croak(q/Usage: $handle->write_content_body(request)/); @_ == 2 || croak(q/Usage: $handle->write_content_body(request)/);
my ($self, $request) = @_; my ($self, $request) = @_;
my ($len, $content_length) = (0, $request->{headers}{'content-length'}); my ($len, $content_length) = (0, $request->{headers}{'content-length'});
@@ -414,9 +416,9 @@ sub write_content_body {
or croak(qq/Content-Length missmatch (got: $len expected: $content_length)/); or croak(qq/Content-Length missmatch (got: $len expected: $content_length)/);
return $len; return $len;
} }
sub read_response_header { sub read_response_header {
@_ == 1 || croak(q/Usage: $handle->read_response_header()/); @_ == 1 || croak(q/Usage: $handle->read_response_header()/);
my ($self) = @_; my ($self) = @_;
@@ -433,17 +435,17 @@ sub read_response_header {
headers => $self->read_header_lines, headers => $self->read_header_lines,
protocol => $protocol, protocol => $protocol,
}; };
} }
sub write_request_header { sub write_request_header {
@_ == 4 || croak(q/Usage: $handle->write_request_header(method, request_uri, headers)/); @_ == 4 || croak(q/Usage: $handle->write_request_header(method, request_uri, headers)/);
my ($self, $method, $request_uri, $headers) = @_; my ($self, $method, $request_uri, $headers) = @_;
return $self->write("$method $request_uri HTTP/1.1\x0D\x0A") return $self->write("$method $request_uri HTTP/1.1\x0D\x0A")
+ $self->write_header_lines($headers); + $self->write_header_lines($headers);
} }
sub _do_timeout { sub _do_timeout {
my ($self, $type, $timeout) = @_; my ($self, $type, $timeout) = @_;
$timeout = $self->{timeout} $timeout = $self->{timeout}
unless defined $timeout && $timeout >= 0; unless defined $timeout && $timeout >= 0;
@@ -472,19 +474,20 @@ sub _do_timeout {
} }
$! = 0; $! = 0;
return $nfound; return $nfound;
} }
sub can_read { sub can_read {
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_read([timeout])/); @_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_read([timeout])/);
my $self = shift; my $self = shift;
return $self->_do_timeout('read', @_) return $self->_do_timeout('read', @_)
} }
sub can_write { sub can_write {
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_write([timeout])/); @_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_write([timeout])/);
my $self = shift; my $self = shift;
return $self->_do_timeout('write', @_) return $self->_do_timeout('write', @_)
} }
} # HTTP::Micro::Handle
# Partially copy-pasted from IO::Socket::SSL 1.76, with some changes because # 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 # 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 = ( my %dispatcher = (
issuer => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_issuer_name( shift )) }, 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 )) }, 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; 1;
}
# ########################################################################### # ###########################################################################
# End HTTPMicro package # End HTTPMicro package
# ########################################################################### # ###########################################################################

43
lib/Percona/WebAPI/Util.pm Normal file
View 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
# ###########################################################################

4
lib/VersionCheck.pm
View File

@@ -40,7 +40,7 @@ use constant PTDEBUG => $ENV{PTDEBUG} || 0;
local $EVAL_ERROR; local $EVAL_ERROR;
eval { eval {
require Percona::Toolkit; require Percona::Toolkit;
require Percona::HTTP::Micro; require HTTP::Micro;
}; };
my $dir = File::Spec->tmpdir(); my $dir = File::Spec->tmpdir();
@@ -163,7 +163,7 @@ sub pingback {
# Optional args # Optional args
my ($instances, $ua, $vc) = @args{qw(instances ua VersionCheck)}; my ($instances, $ua, $vc) = @args{qw(instances ua VersionCheck)};
$ua ||= HTTPMicro->new( timeout => 5 ); $ua ||= HTTP::Micro->new( timeout => 5 );
$vc ||= VersionCheck->new(); $vc ||= VersionCheck->new();
# GET https://upgrade.percona.com, the server will return # GET https://upgrade.percona.com, the server will return

6
t/lib/HTTPMicro.t → t/lib/HTTP/Micro.t
View File

@@ -11,7 +11,7 @@ use warnings FATAL => 'all';
use English qw(-no_match_vars); use English qw(-no_match_vars);
use Test::More; use Test::More;
use HTTPMicro; use HTTP::Micro;
local $EVAL_ERROR; local $EVAL_ERROR;
eval { require HTTP::Tiny }; eval { require HTTP::Tiny };
@@ -22,12 +22,12 @@ if ( $EVAL_ERROR ) {
# Need a simple URL that won't try to do chunking. # 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" ) { 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 $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( like(
$micro->{content}, $micro->{content},
qr/^\Q$tiny->{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
View 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
View 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;