percona/percona-toolkit
1
0
Fork 0
mirror of https://github.com/percona/percona-toolkit.git synced 2025-09-11 05:29:30 +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

384
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;
@@ -4297,7 +4339,7 @@ sub main {
} }
Pingback::validate_options($o); Pingback::validate_options($o);
$o->usage_or_errors(); $o->usage_or_errors();
# ######################################################################## # ########################################################################
@@ -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.
api_key => $api_key, # TODO: make user-configurable? --reconnect-interval?
agent_id => $o->get('agent-id'), my $init_interval = 120;
check_interval => $o->get('check-interval'), 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; 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(); eval {
if ( resource_diff($config, $new_config) ) { _info('Getting config');
_log('Got new config'); my $new_config = $client->get(
eval { url => $client->links->{config},
write_config(); );
}; if ( resource_diff($config, $new_config) ) {
if ( $EVAL_ERROR ) { _info('Got new config');
} write_config(
else { config => $config,
file => $config_file,
);
$config = $new_config; $config = $new_config;
} }
};
if ( $EVAL_ERROR ) {
_warn($EVAL_ERROR);
} }
my $new_services = get_services(); if ( $config ) {
if ( resource_diff($services, $new_services) ) { eval {
_log('Got new services'); _info('Getting services');
write_services(); my $new_services = $client->get(
schedule_services(); 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"); # 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';
} }

563
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,322 +167,327 @@ 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);
local $_ = shift; use Errno qw(EINTR EPIPE);
s/\r/\\r/g; use IO::Socket qw(SOCK_STREAM);
s/\n/\\n/g;
s/\t/\\t/g;
s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;
$_;
};
sub new { sub BUFSIZE () { 32768 }
my ($class, %args) = @_;
return bless {
rbuf => '',
timeout => 60,
max_line_size => 16384,
%args
}, $class;
}
my $ssl_verify_args = { my $Printable = sub {
check_cn => "when_only", local $_ = shift;
wildcards_in_alt => "anywhere", s/\r/\\r/g;
wildcards_in_cn => "anywhere" s/\n/\\n/g;
}; s/\t/\\t/g;
s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;
$_;
};
sub connect { sub new {
@_ == 4 || croak(q/Usage: $handle->connect(scheme, host, port)/); my ($class, %args) = @_;
my ($self, $scheme, $host, $port) = @_; return bless {
rbuf => '',
timeout => 60,
max_line_size => 16384,
%args
}, $class;
}
if ( $scheme eq 'https' ) { my $ssl_verify_args = {
eval "require IO::Socket::SSL" check_cn => "when_only",
unless exists $INC{'IO/Socket/SSL.pm'}; wildcards_in_alt => "anywhere",
croak(qq/IO::Socket::SSL must be installed for https support\n/) wildcards_in_cn => "anywhere"
unless $INC{'IO/Socket/SSL.pm'}; };
}
elsif ( $scheme ne 'http' ) {
croak(qq/Unsupported URL scheme '$scheme'\n/);
}
$self->{fh} = 'IO::Socket::INET'->new( sub connect {
PeerHost => $host, @_ == 4 || croak(q/Usage: $handle->connect(scheme, host, port)/);
PeerPort => $port, my ($self, $scheme, $host, $port) = @_;
Proto => 'tcp',
Type => SOCK_STREAM,
Timeout => $self->{timeout}
) or croak(qq/Could not connect to '$host:$port': $@/);
binmode($self->{fh}) if ( $scheme eq 'https' ) {
or croak(qq/Could not binmode() socket: '$!'/); 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') { $self->{fh} = IO::Socket::INET->new(
IO::Socket::SSL->start_SSL($self->{fh}); PeerHost => $host,
ref($self->{fh}) eq 'IO::Socket::SSL' PeerPort => $port,
or die(qq/SSL connection failed for $host\n/); Proto => 'tcp',
if ( $self->{fh}->can("verify_hostname") ) { Type => SOCK_STREAM,
$self->{fh}->verify_hostname( $host, $ssl_verify_args ); Timeout => $self->{timeout}
} ) or croak(qq/Could not connect to '$host:$port': $@/);
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->{host} = $host;
$self->{port} = $port;
return $self; binmode($self->{fh})
} or croak(qq/Could not binmode() socket: '$!'/);
sub close { if ( $scheme eq 'https') {
@_ == 1 || croak(q/Usage: $handle->close()/); IO::Socket::SSL->start_SSL($self->{fh});
my ($self) = @_; ref($self->{fh}) eq 'IO::Socket::SSL'
CORE::close($self->{fh}) or die(qq/SSL connection failed for $host\n/);
or croak(qq/Could not close socket: '$!'/); 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->{host} = $host;
$self->{port} = $port;
sub write { return $self;
@_ == 2 || croak(q/Usage: $handle->write(buf)/); }
my ($self, $buf) = @_;
my $len = length $buf; sub close {
my $off = 0; @_ == 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 () { my $len = length $buf;
$self->can_write my $off = 0;
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;
}
sub read { local $SIG{PIPE} = 'IGNORE';
@_ == 2 || @_ == 3 || croak(q/Usage: $handle->read(len)/);
my ($self, $len) = @_;
my $buf = ''; while () {
my $got = length $self->{rbuf}; $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) { sub read {
my $take = ($got < $len) ? $got : $len; @_ == 2 || @_ == 3 || croak(q/Usage: $handle->read(len)/);
$buf = substr($self->{rbuf}, 0, $take, ''); my ($self, $len) = @_;
$len -= $take;
}
while ($len > 0) { my $buf = '';
$self->can_read my $got = length $self->{rbuf};
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 readline { if ($got) {
@_ == 1 || croak(q/Usage: $handle->readline()/); my $take = ($got < $len) ? $got : $len;
my ($self) = @_; $buf = substr($self->{rbuf}, 0, $take, '');
$len -= $take;
}
while () { while ($len > 0) {
if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) { $self->can_read
return $1; or croak(q/Timed out while waiting for socket to become ready for reading/);
} my $r = sysread($self->{fh}, $buf, $len, length $buf);
$self->can_read if (defined $r) {
or croak(q/Timed out while waiting for socket to become ready for reading/); last unless $r;
my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf}); $len -= $r;
if (defined $r) { }
last unless $r; elsif ($! != EINTR) {
} croak(qq/Could not read from socket: '$!'/);
elsif ($! != EINTR) { }
croak(qq/Could not read from socket: '$!'/); }
} if ($len) {
} croak(q/Unexpected end of stream/);
croak(q/Unexpected end of stream while looking for line/); }
} return $buf;
}
sub read_header_lines { sub readline {
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->read_header_lines([headers])/); @_ == 1 || croak(q/Usage: $handle->readline()/);
my ($self, $headers) = @_; my ($self) = @_;
$headers ||= {};
my $lines = 0;
my $val;
while () { while () {
my $line = $self->readline; 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) { sub read_header_lines {
my ($field_name) = lc $1; @_ == 1 || @_ == 2 || croak(q/Usage: $handle->read_header_lines([headers])/);
$val = \($headers->{$field_name} = $2); my ($self, $headers) = @_;
} $headers ||= {};
elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) { my $lines = 0;
$val my $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 write_header_lines { while () {
(@_ == 2 && ref $_[1] eq 'HASH') || croak(q/Usage: $handle->write_header_lines(headers)/); my $line = $self->readline;
my($self, $headers) = @_;
my $buf = ''; if ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) {
while (my ($k, $v) = each %$headers) { my ($field_name) = lc $1;
my $field_name = lc $k; $val = \($headers->{$field_name} = $2);
$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)); elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) {
$field_name =~ s/\b(\w)/\u$1/g; $val
$buf .= "$field_name: $v\x0D\x0A"; or croak(q/Unexpected header continuation line/);
} next unless length $1;
$buf .= "\x0D\x0A"; $$val .= ' ' if length $$val;
return $self->write($buf); $$val .= $1;
} }
elsif ($line =~ /\A \x0D?\x0A \z/x) {
last;
}
else {
croak(q/Malformed header line: / . $Printable->($line));
}
}
return $headers;
}
sub read_content_body { sub write_header_lines {
@_ == 3 || @_ == 4 || croak(q/Usage: $handle->read_content_body(callback, response, [read_length])/); (@_ == 2 && ref $_[1] eq 'HASH') || croak(q/Usage: $handle->write_header_lines(headers)/);
my ($self, $cb, $response, $len) = @_; my($self, $headers) = @_;
$len ||= $response->{headers}{'content-length'};
croak("No content-length in the returned response, and this " my $buf = '';
. "UA doesn't implement chunking") unless defined $len; 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) { sub read_content_body {
my $read = ($len > BUFSIZE) ? BUFSIZE : $len; @_ == 3 || @_ == 4 || croak(q/Usage: $handle->read_content_body(callback, response, [read_length])/);
$cb->($self->read($read), $response); my ($self, $cb, $response, $len) = @_;
$len -= $read; $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 { while ($len > 0) {
@_ == 2 || croak(q/Usage: $handle->write_content_body(request)/); my $read = ($len > BUFSIZE) ? BUFSIZE : $len;
my ($self, $request) = @_; $cb->($self->read($read), $response);
my ($len, $content_length) = (0, $request->{headers}{'content-length'}); $len -= $read;
}
$len += $self->write($request->{content}); return;
}
$len == $content_length sub write_content_body {
or croak(qq/Content-Length missmatch (got: $len expected: $content_length)/); @_ == 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 { $len == $content_length
@_ == 1 || croak(q/Usage: $handle->read_response_header()/); or croak(qq/Content-Length missmatch (got: $len expected: $content_length)/);
my ($self) = @_;
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 sub read_response_header {
or croak(q/Malformed Status-Line: / . $Printable->($line)); @_ == 1 || croak(q/Usage: $handle->read_response_header()/);
my ($self) = @_;
my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4); my $line = $self->readline;
return { $line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x
status => $status, or croak(q/Malformed Status-Line: / . $Printable->($line));
reason => $reason,
headers => $self->read_header_lines,
protocol => $protocol,
};
}
sub write_request_header { my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4);
@_ == 4 || croak(q/Usage: $handle->write_request_header(method, request_uri, headers)/);
my ($self, $method, $request_uri, $headers) = @_;
return $self->write("$method $request_uri HTTP/1.1\x0D\x0A") return {
+ $self->write_header_lines($headers); status => $status,
} reason => $reason,
headers => $self->read_header_lines,
protocol => $protocol,
};
}
sub _do_timeout { sub write_request_header {
my ($self, $type, $timeout) = @_; @_ == 4 || croak(q/Usage: $handle->write_request_header(method, request_uri, headers)/);
$timeout = $self->{timeout} my ($self, $method, $request_uri, $headers) = @_;
unless defined $timeout && $timeout >= 0;
my $fd = fileno $self->{fh}; return $self->write("$method $request_uri HTTP/1.1\x0D\x0A")
defined $fd && $fd >= 0 + $self->write_header_lines($headers);
or croak(q/select(2): 'Bad file descriptor'/); }
my $initial = time; sub _do_timeout {
my $pending = $timeout; my ($self, $type, $timeout) = @_;
my $nfound; $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 () { my $initial = time;
$nfound = ($type eq 'read') my $pending = $timeout;
? select($fdset, undef, undef, $pending) my $nfound;
: 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 { vec(my $fdset = '', $fd, 1) = 1;
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_read([timeout])/);
my $self = shift;
return $self->_do_timeout('read', @_)
}
sub can_write { while () {
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_write([timeout])/); $nfound = ($type eq 'read')
my $self = shift; ? select($fdset, undef, undef, $pending)
return $self->_do_timeout('write', @_) : 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 # 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;