« back to all changes in this revision
Viewing changes to lib/Pingback.pm
- browse files at revision 365
- compare with another revision
- download diff
- download tarball
- view history from revision 365
- Committer: Daniel Nichter
- Date: 2012-08-23 01:59:55 UTC
- mfrom: (350.1.29 pingback-feature)
- Revision ID: daniel@percona.com-20120823015955-5amltej7vn72sz9w
Merge lp:~percona-toolkit-dev/percona-toolkit/pingback-feature
- files added:
- lib/HTTPMicro.pm
- lib/Percona
- files modified:
- bin/pt-archiver
added
removed
lib/Pingback.pm
1
# This program is copyright 2012 Percona Inc.
2
# Feedback and improvements are welcome.
3
#
4
# THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
5
# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
6
# MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
7
#
8
# This program is free software; you can redistribute it and/or modify it under
9
# the terms of the GNU General Public License as published by the Free Software
10
# Foundation, version 2; OR the Perl Artistic License. On UNIX and similar
11
# systems, you can issue `man perlgpl' or `man perlartistic' to read these
12
# licenses.
13
#
14
# You should have received a copy of the GNU General Public License along with
15
# this program; if not, write to the Free Software Foundation, Inc., 59 Temple
16
# Place, Suite 330, Boston, MA 02111-1307 USA.
17
# ###########################################################################
18
# VersionCheck package
19
# ###########################################################################
20
{
21
# Package: Pingback
22
# Pingback gets and reports program versions to Percona.
23
package Pingback;
24
25
use strict;
26
use warnings FATAL => 'all';
27
use English qw(-no_match_vars);
28
29
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
30
31
use File::Basename qw();
32
use Data::Dumper qw();
33
use Fcntl qw(:DEFAULT);
34
35
use File::Spec;
36
37
my $dir = File::Spec->tmpdir();
38
my $check_time_file = File::Spec->catfile($dir,'percona-toolkit-version-check');
39
my $check_time_limit = 60 * 60 * 24; # one day
40
41
sub Dumper {
42
local $Data::Dumper::Indent = 1;
43
local $Data::Dumper::Sortkeys = 1;
44
local $Data::Dumper::Quotekeys = 0;
45
46
Data::Dumper::Dumper(@_);
47
}
48
49
local $EVAL_ERROR;
50
eval {
51
require HTTPMicro;
52
require VersionCheck;
53
};
54
55
sub version_check {
56
# If this blows up, oh well, don't bother the user about it.
57
# This feature is a "best effort" only; we don't want it to
58
# get in the way of the tool's real work.
59
eval {
60
if (exists $ENV{PERCONA_VERSION_CHECK} && !$ENV{PERCONA_VERSION_CHECK}) {
61
if ( $ENV{PTVCDEBUG} || PTDEBUG ) {
62
_d('--version-check is disabled by the PERCONA_VERSION_CHECK',
63
'environment variable');
64
}
65
return;
66
}
67
68
if ( !time_to_check($check_time_file) ) {
69
if ( $ENV{PTVCDEBUG} || PTDEBUG ) {
70
_d('It is not time to --version-checka again;',
71
'only 1 check per', $check_time_limit, 'seconds, and the last',
72
'check was performed on the modified time of', $check_time_file);
73
}
74
return;
75
}
76
77
my $dbh = shift; # optional
78
my $advice = pingback(
79
url => $ENV{PERCONA_VERSION_CHECK_URL} || 'http://v.percona.com',
80
dbh => $dbh,
81
);
82
if ( $advice ) {
83
print "# Percona suggests these upgrades:\n";
84
print join("\n", map { "# * $_" } @$advice);
85
print "\n# Specify --no-version-check to disable these suggestions.\n\n";
86
}
87
elsif ( $ENV{PTVCDEBUG} || PTDEBUG ) {
88
_d('--version-check worked, but there were no suggestions');
89
}
90
};
91
if ( $EVAL_ERROR ) {
92
if ( $ENV{PTVCDEBUG} || PTDEBUG ) {
93
_d('Error doing --version-check:', $EVAL_ERROR);
94
}
95
}
96
97
return;
98
}
99
100
sub pingback {
101
my (%args) = @_;
102
my @required_args = qw(url);
103
foreach my $arg ( @required_args ) {
104
die "I need a $arg arugment" unless $args{$arg};
105
}
106
my ($url) = @args{@required_args};
107
108
# Optional args
109
my ($dbh, $ua, $vc) = @args{qw(dbh ua VersionCheck)};
110
111
$ua ||= HTTPMicro->new( timeout => 2 );
112
$vc ||= VersionCheck->new();
113
114
# GET http://upgrade.percona.com, the server will return
115
# a plaintext list of items/programs it wants the tool
116
# to get, one item per line with the format ITEM;TYPE[;VARS]
117
# ITEM is the pretty name of the item/program; TYPE is
118
# the type of ITEM that helps the tool determine how to
119
# get the item's version; and VARS is optional for certain
120
# items/types that need extra hints.
121
my $response = $ua->request('GET', $url);
122
PTDEBUG && _d('Server response:', Dumper($response));
123
die "No response from GET $url"
124
if !$response;
125
die "GET $url returned HTTP status $response->{status}; expected 200"
126
if $response->{status} != 200;
127
die "GET $url did not return any programs to check"
128
if !$response->{content};
129
130
# Parse the plaintext server response into a hashref keyed on
131
# the items like:
132
# "MySQL" => {
133
# item => "MySQL",
134
# type => "mysql_variables",
135
# vars => ["version", "version_comment"],
136
# }
137
my $items = $vc->parse_server_response(
138
response => $response->{content}
139
);
140
die "Failed to parse server requested programs: $response->{content}"
141
if !scalar keys %$items;
142
143
# Get the versions for those items in another hashref also keyed on
144
# the items like:
145
# "MySQL" => "MySQL Community Server 5.1.49-log",
146
my $versions = $vc->get_versions(
147
items => $items,
148
dbh => $dbh,
149
);
150
die "Failed to get any program versions; should have at least gotten Perl"
151
if !scalar keys %$versions;
152
153
# Join the items and whatever versions are available and re-encode
154
# them in same simple plaintext item-per-line protocol, and send
155
# it back to Percona.
156
my $client_content = encode_client_response(
157
items => $items,
158
versions => $versions,
159
);
160
161
my $client_response = {
162
headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) },
163
content => $client_content,
164
};
165
PTDEBUG && _d('Client response:', Dumper($client_response));
166
167
$response = $ua->request('POST', $url, $client_response);
168
PTDEBUG && _d('Server suggestions:', Dumper($response));
169
die "No response from POST $url $client_response"
170
if !$response;
171
die "POST $url returned HTTP status $response->{status}; expected 200"
172
if $response->{status} != 200;
173
174
# If the server does not have any suggestions,
175
# there will not be any content.
176
return unless $response->{content};
177
178
# If the server has suggestions for items, it sends them back in
179
# the same format: ITEM:TYPE:SUGGESTION\n. ITEM:TYPE is mostly for
180
# debugging; the tool just repports the suggestions.
181
$items = $vc->parse_server_response(
182
response => $response->{content},
183
split_vars => 0,
184
);
185
die "Failed to parse server suggestions: $response->{content}"
186
if !scalar keys %$items;
187
my @suggestions = map { $_->{vars} }
188
sort { $a->{item} cmp $b->{item} }
189
values %$items;
190
191
return \@suggestions;
192
}
193
194
sub time_to_check {
195
my ($file) = @_;
196
die "I need a file argument" unless $file;
197
198
if ( !-f $file ) {
199
PTDEBUG && _d('Creating', $file);
200
_touch($file);
201
return 1;
202
}
203
204
my $mtime = (stat $file)[9];
205
if ( !defined $mtime ) {
206
PTDEBUG && _d('Error getting modified time of', $file);
207
return 0;
208
}
209
210
# Otherwise, if there's been more than a day since the last check,
211
# update the file and return true.
212
my $time = int(time());
213
PTDEBUG && _d('time=', $time, 'mtime=', $mtime);
214
if ( ($time - $mtime) > $check_time_limit ) {
215
_touch($file);
216
return 1;
217
}
218
219
# Otherwise, we're still within the day, so don't do the version check.
220
return 0;
221
}
222
223
sub _touch {
224
my ($file) = @_;
225
sysopen my $fh, $file, O_WRONLY|O_CREAT|O_NONBLOCK
226
or die "Cannot create $file : $!";
227
close $fh or die "Cannot close $file : $!";
228
utime(undef, undef, $file);
229
}
230
231
sub encode_client_response {
232
my (%args) = @_;
233
my @required_args = qw(items versions);
234
foreach my $arg ( @required_args ) {
235
die "I need a $arg arugment" unless $args{$arg};
236
}
237
my ($items, $versions) = @args{@required_args};
238
239
# There may not be a version for each item. For example, the server
240
# may have requested the "MySQL" (version) item, but if the tool
241
# didn't connect to MySQL, there won't be a $versions->{MySQL}.
242
# That's ok; just use what we've got.
243
# NOTE: the sort is only need to make testing deterministic.
244
my @lines;
245
foreach my $item ( sort keys %$items ) {
246
next unless exists $versions->{$item};
247
push @lines, join(';', $item, $versions->{$item});
248
}
249
250
my $client_response = join("\n", @lines) . "\n";
251
PTDEBUG && _d('Client response:', $client_response);
252
return $client_response;
253
}
254
255
sub _d {
256
my ($package, undef, $line) = caller 0;
257
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
258
map { defined $_ ? $_ : 'undef' }
259
@_;
260
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
261
}
262
263
1;
264
}
265
# ###########################################################################
266
# End Pingback package
267
# ###########################################################################
Loggerhead is a web-based interface for Breezy
Version: 2.0.1