mirror of
https://github.com/percona/percona-toolkit.git
synced 2025-09-20 02:44:58 +00:00
Clean up Pingback.pm, make it encode the client response correctly, and abstract and rewrite the tests.
This commit is contained in:
Daniel Nichter
128
lib/Pingback.pm
128
lib/Pingback.pm
@@ -1,10 +1,38 @@
|
||||
# This program is copyright 2012 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.
|
||||
# ###########################################################################
|
||||
# VersionCheck package
|
||||
# ###########################################################################
|
||||
{
|
||||
# Package: Pingback
|
||||
# Pingback gets and reports program versions to Percona.
|
||||
package Pingback;
|
||||
|
||||
use strict;
|
||||
use warnings FATAL => 'all';
|
||||
use English qw(-no_match_vars);
|
||||
|
||||
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
|
||||
|
||||
use Data::Dumper;
|
||||
$Data::Dumper::Indent = 1;
|
||||
$Data::Dumper::Sortkeys = 1;
|
||||
$Data::Dumper::Quotekeys = 0;
|
||||
|
||||
local $EVAL_ERROR;
|
||||
eval {
|
||||
require HTTPMicro;
|
||||
@@ -12,29 +40,95 @@ eval {
|
||||
};
|
||||
|
||||
sub pingback {
|
||||
my ($url, $dbh, $ua) = @_; # pingback($url, $dbh[, $ua])
|
||||
$ua ||= HTTP::Micro->new();
|
||||
|
||||
my $response = $ua->request('GET', $url);
|
||||
|
||||
if ( $response->{status} >= 500
|
||||
|| exists $response->{reason}
|
||||
|| !exists $response->{content} )
|
||||
{
|
||||
return;
|
||||
my (%args) = @_;
|
||||
my @required_args = qw(url);
|
||||
foreach my $arg ( @required_args ) {
|
||||
die "I need a $arg arugment" unless $args{$arg};
|
||||
}
|
||||
my ($url) = @args{@required_args};
|
||||
|
||||
my $items = VersionCheck->parse_server_response(response => $response->{content});
|
||||
my $checks = VersionCheck->get_versions(items => $items, dbh => $dbh);
|
||||
# Optional args
|
||||
my ($dbh, $ua, $vc) = @args{qw(dbh ua VersionCheck)};
|
||||
|
||||
my $options = { content => encode_to_plaintext($checks) };
|
||||
$ua ||= HTTP::Micro->new();
|
||||
$vc ||= VersionCheck->new();
|
||||
|
||||
return $ua->request('POST', $url, $options);
|
||||
# GET http://upgrade.percona.com, the server will return
|
||||
# a plaintext list of items/programs it wants the tool
|
||||
# to get, one item per line with the format ITEM;TYPE[;VARS]
|
||||
# ITEM is the pretty name of the item/program; TYPE is
|
||||
# the type of ITEM that helps the tool determine how to
|
||||
# get the item's version; and VARS is optional for certain
|
||||
# items/types that need extra hints.
|
||||
my $response = $ua->request('GET', $url);
|
||||
PTDEBUG && _d('Server response:', Dumper($response));
|
||||
return unless $response->{status} == 200;
|
||||
|
||||
# Parse the plaintext server response into a hashref keyed on
|
||||
# the items like:
|
||||
# "MySQL" => {
|
||||
# item => "MySQL",
|
||||
# type => "mysql_variables",
|
||||
# vars => ["version", "version_comment"],
|
||||
# }
|
||||
my $items = $vc->parse_server_response(
|
||||
response => $response->{content}
|
||||
);
|
||||
return unless scalar keys %$items;
|
||||
|
||||
# Get the versions for those items in another hashref also keyed on
|
||||
# the items like:
|
||||
# "MySQL" => "MySQL Community Server 5.1.49-log",
|
||||
my $versions = $vc->get_versions(
|
||||
items => $items,
|
||||
dbh => $dbh,
|
||||
);
|
||||
return unless scalar keys %$versions;
|
||||
|
||||
# Join the items and whatever veersions are available and re-encode
|
||||
# them in same simple plaintext item-per-line protocol, and send
|
||||
# it back to Percona.
|
||||
my $client_response = encode_client_response(
|
||||
items => $items,
|
||||
versions => $versions,
|
||||
);
|
||||
return $ua->request('POST', $url, $client_response);
|
||||
}
|
||||
|
||||
sub encode_to_plaintext {
|
||||
my $data = shift;
|
||||
return join "\n", map { "$_,$data->{$_}" } keys %$data;
|
||||
sub encode_client_response {
|
||||
my (%args) = @_;
|
||||
my @required_args = qw(items versions);
|
||||
foreach my $arg ( @required_args ) {
|
||||
die "I need a $arg arugment" unless $args{$arg};
|
||||
}
|
||||
my ($items, $versions) = @args{@required_args};
|
||||
|
||||
# There may not be a version for each item. For example, the server
|
||||
# may have requested the "MySQL" (version) item, but if the tool
|
||||
# didn't connect to MySQL, there won't be a $versions->{MySQL}.
|
||||
# That's ok; just use what we've got.
|
||||
# NOTE: the sort is only need to make testing deterministic.
|
||||
my @lines;
|
||||
foreach my $item ( sort keys %$items ) {
|
||||
next unless exists $versions->{$item};
|
||||
push @lines, join(';', $item,$items->{$item}->{type},$versions->{$item});
|
||||
}
|
||||
|
||||
my $client_response = join("\n", @lines) . "\n";
|
||||
PTDEBUG && _d('Client response:', $client_response);
|
||||
return $client_response;
|
||||
}
|
||||
|
||||
sub _d {
|
||||
my ($package, undef, $line) = caller 0;
|
||||
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
|
||||
map { defined $_ ? $_ : 'undef' }
|
||||
@_;
|
||||
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
|
||||
}
|
||||
|
||||
1;
|
||||
}
|
||||
# ###########################################################################
|
||||
# End Pingback package
|
||||
# ###########################################################################
|
||||
|
||||
157
t/lib/Pingback.t
157
t/lib/Pingback.t
@@ -11,85 +11,108 @@ use warnings FATAL => 'all';
|
||||
use English qw(-no_match_vars);
|
||||
use Test::More;
|
||||
|
||||
use PerconaTest;
|
||||
|
||||
use Pingback;
|
||||
|
||||
my @requests;
|
||||
{
|
||||
package FakeUA;
|
||||
|
||||
sub new { bless $_[1], $_[0] }
|
||||
sub request {
|
||||
my ($self, $type, $url, $content) = @_;
|
||||
|
||||
if ( $type ne 'GET' ) {
|
||||
push @requests, $content;
|
||||
}
|
||||
return shift @{ $self };
|
||||
}
|
||||
}
|
||||
|
||||
my $fake_ua = FakeUA->new([
|
||||
{ status => 200, content => "Perl;perl_variable;PERL_VERSION\nData::Dumper;perl_variable\n" }, # GET 1
|
||||
{ status => 200, }, # POST 1
|
||||
{ status => 200, content => "Perl;perl_variable;PERL_VERSION\nMySQL;mysql_variable;version_comment,version\n", }, # GET 2
|
||||
{ status => 200, }, # POST 2
|
||||
]);
|
||||
|
||||
@requests = ();
|
||||
Pingback::pingback('http://www.percona.com/fake_url', undef, $fake_ua);
|
||||
|
||||
is(
|
||||
scalar @requests,
|
||||
1,
|
||||
"..and it sends one request"
|
||||
);
|
||||
|
||||
my $v = sprintf('Perl,%vd', $^V);
|
||||
like(
|
||||
$requests[0]->{content},
|
||||
qr/\Q$v/,
|
||||
"..which has the expected version of Perl"
|
||||
);
|
||||
|
||||
like(
|
||||
$requests[0]->{content},
|
||||
qr/\Q$Data::Dumper::VERSION/,
|
||||
"..and the expected D::D version"
|
||||
);
|
||||
|
||||
#@requests = ();
|
||||
#my ($out) = full_output( sub { Pingback::pingback('http://www.percona.com/fake_url', undef, $fake_ua) } );
|
||||
#
|
||||
|
||||
use PerconaTest;
|
||||
use DSNParser;
|
||||
use Sandbox;
|
||||
my $dp = DSNParser->new(opts=>$dsn_opts);
|
||||
my $sb = Sandbox->new(basedir => '/tmp', DSNParser => $dp);
|
||||
my $dbh = $sb->get_dbh_for('master');
|
||||
SKIP: {
|
||||
skip 'Cannot connect to sandbox master', 3 unless $dbh;
|
||||
|
||||
my (undef, $mysql_version)
|
||||
= $dbh->selectrow_array("SHOW VARIABLES LIKE 'version'");
|
||||
my (undef, $mysql_version_comment)
|
||||
= $dbh->selectrow_array("SHOW VARIABLES LIKE 'version_comment'");
|
||||
# #############################################################################
|
||||
# Fake User Agent package, so we can simulate server responses
|
||||
# and fake accepting client responses.
|
||||
# #############################################################################
|
||||
|
||||
@requests = ();
|
||||
Pingback::pingback('http://www.percona.com/fake_url', $dbh, $fake_ua);
|
||||
my $get; # server reponses
|
||||
my $post; # client responses
|
||||
{
|
||||
package FakeUA;
|
||||
|
||||
like(
|
||||
$requests[0]->{content},
|
||||
qr/\Q$v/,
|
||||
"Second request has the expected version of Perl"
|
||||
sub new { bless {}, $_[0] }
|
||||
sub request {
|
||||
my ($self, $type, $url, $content) = @_;
|
||||
return shift @$get if $type eq 'GET';
|
||||
$post = $content if $type eq 'POST';
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
my $fake_ua = FakeUA->new();
|
||||
|
||||
# #############################################################################
|
||||
# Pingback tests
|
||||
# #############################################################################
|
||||
|
||||
my $url = 'http://upgrade.percona.com';
|
||||
my $perl_ver = sprintf '%vd', $PERL_VERSION;
|
||||
my $dd_ver = $Data::Dumper::VERSION;
|
||||
|
||||
sub test_pingback {
|
||||
my (%args) = @_;
|
||||
|
||||
$get = $args{get};
|
||||
$post = ""; # clear previous test
|
||||
|
||||
eval {
|
||||
Pingback::pingback(
|
||||
url => $url,
|
||||
dbh => $args{dbh},
|
||||
ua => $fake_ua,
|
||||
);
|
||||
};
|
||||
is(
|
||||
$EVAL_ERROR,
|
||||
"",
|
||||
"$args{name} no error"
|
||||
);
|
||||
|
||||
like(
|
||||
$requests[0]->{content},
|
||||
qr/\Q$mysql_version_comment $mysql_version/,
|
||||
"..and gets the MySQL version"
|
||||
is(
|
||||
$post,
|
||||
$args{post},
|
||||
"$args{name} client response"
|
||||
)
|
||||
}
|
||||
|
||||
test_pingback(
|
||||
name => "Perl version and Data::Dumper::VERSION",
|
||||
# Client gets this from the server:
|
||||
get => [
|
||||
{ status => 200,
|
||||
content => "Perl;perl_variable;PERL_VERSION\nData::Dumper;perl_variable\n",
|
||||
},
|
||||
],
|
||||
# And it responds with this:
|
||||
post => "Data::Dumper;perl_variable;$dd_ver\nPerl;perl_variable;$perl_ver\n",
|
||||
);
|
||||
|
||||
# #############################################################################
|
||||
# MySQL version
|
||||
# #############################################################################
|
||||
SKIP: {
|
||||
skip 'Cannot connect to sandbox master', 2 unless $dbh;
|
||||
|
||||
my (undef, $mysql_ver)
|
||||
= $dbh->selectrow_array("SHOW VARIABLES LIKE 'version'");
|
||||
my (undef, $mysql_distro)
|
||||
= $dbh->selectrow_array("SHOW VARIABLES LIKE 'version_comment'");
|
||||
|
||||
test_pingback(
|
||||
name => "MySQL version",
|
||||
get => [
|
||||
{ status => 200,
|
||||
content => "MySQL;mysql_variable;version,version_comment\n",
|
||||
},
|
||||
],
|
||||
post => "MySQL;mysql_variable;$mysql_ver $mysql_distro\n",
|
||||
dbh => $dbh,
|
||||
);
|
||||
}
|
||||
|
||||
# #############################################################################
|
||||
# Done.
|
||||
# #############################################################################
|
||||
ok($sb->ok(), "Sandbox servers") or BAIL_OUT(__FILE__ . " broke the sandbox")
|
||||
if $dbh;
|
||||
done_testing;
|
||||
exit;
|
||||
|
||||
@@ -177,6 +177,7 @@ ok(
|
||||
# #############################################################################
|
||||
# Done.
|
||||
# #############################################################################
|
||||
ok($sb->ok(), "Sandbox servers") or BAIL_OUT(__FILE__ . " broke the sandbox") if $dbh;
|
||||
ok($sb->ok(), "Sandbox servers") or BAIL_OUT(__FILE__ . " broke the sandbox")
|
||||
if $dbh;
|
||||
done_testing;
|
||||
exit;
|
||||
|
||||
Reference in New Issue
Block a user