From d8bb594059c993419c27088253dbdf83880ca020 Mon Sep 17 00:00:00 2001 From: Daniel Nichter Date: Thu, 9 Aug 2012 12:47:30 -0600 Subject: [PATCH] Clean up Pingback.pm, make it encode the client response correctly, and abstract and rewrite the tests. --- lib/Pingback.pm | 128 +++++++++++++++++++++++++++++----- t/lib/Pingback.t | 159 +++++++++++++++++++++++++------------------ t/lib/VersionCheck.t | 3 +- 3 files changed, 204 insertions(+), 86 deletions(-) diff --git a/lib/Pingback.pm b/lib/Pingback.pm index 9ba1c3fc..76a6a4f5 100644 --- a/lib/Pingback.pm +++ b/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 +# ########################################################################### diff --git a/t/lib/Pingback.t b/t/lib/Pingback.t index 682495ca..fe7c196b 100644 --- a/t/lib/Pingback.t +++ b/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'"); - - @requests = (); - Pingback::pingback('http://www.percona.com/fake_url', $dbh, $fake_ua); +# ############################################################################# +# Fake User Agent package, so we can simulate server responses +# and fake accepting client responses. +# ############################################################################# - like( - $requests[0]->{content}, - qr/\Q$v/, - "Second request has the expected version of Perl" +my $get; # server reponses +my $post; # client responses +{ + package FakeUA; + + 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; diff --git a/t/lib/VersionCheck.t b/t/lib/VersionCheck.t index 8d113f9e..5ab3030e 100644 --- a/t/lib/VersionCheck.t +++ b/t/lib/VersionCheck.t @@ -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;