diff --git a/bin/pt-agent b/bin/pt-agent index 5e50e9e8..1e0d349b 100755 --- a/bin/pt-agent +++ b/bin/pt-agent @@ -24,6 +24,7 @@ BEGIN { Percona::WebAPI::Resource::Service Percona::WebAPI::Resource::Run Percona::WebAPI::Representation + Percona::WebAPI::Util VersionCheck DSNParser OptionParser @@ -1233,6 +1234,39 @@ sub as_config { # 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 # 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; eval { require Percona::Toolkit; - require Percona::HTTP::Micro; + require HTTP::Micro; }; my $dir = File::Spec->tmpdir(); @@ -1374,7 +1408,7 @@ sub pingback { my ($instances, $ua, $vc) = @args{qw(instances ua VersionCheck)}; - $ua ||= HTTPMicro->new( timeout => 5 ); + $ua ||= HTTP::Micro->new( timeout => 5 ); $vc ||= VersionCheck->new(); my $response = $ua->request('GET', $url); @@ -4265,13 +4299,21 @@ package pt_agent; use strict; use warnings FATAL => 'all'; use English qw(-no_match_vars); - -use Percona::Toolkit; use constant PTDEBUG => $ENV{PTDEBUG} || 0; use POSIX qw(signal_h); 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'; my $oktorun = 1; @@ -4297,7 +4339,7 @@ sub main { } Pingback::validate_options($o); - + $o->usage_or_errors(); # ######################################################################## @@ -4305,15 +4347,40 @@ sub main { # ######################################################################## my $api_key = $o->get('api-key'); if ( !$api_key ) { - die "Error starting pt-agent: missing API key. pt-agent requires " - . "a Percona Web Services API key to run. Specify your API key " - . "in a --config file or with --api-key. Please contact Percona " - . "if you need help. pt-agent is not running.\n"; + _err("No API key was found or specified. pt-agent requires a " + . "Percona Web Services API key to run. Put your API key " + . "in a --config file or specify it with --api-key."); + } + + # ######################################################################## + # 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. # ######################################################################## + my $daemon; + if ( my $service = $o->get('run-service') ) { run_service( service => $service, @@ -4333,7 +4400,6 @@ sub main { # process. Only internal errors should cause it to stop. Else, # external errors, like Percona web API not responding, should be # retried forever. - my $daemon; if ( $o->get('daemonize') ) { $daemon = new Daemon(o=>$o); $daemon->daemonize(); @@ -4344,15 +4410,54 @@ sub main { $daemon->make_PID_file(); } - # Start or create the agent. - init_agent( - api_key => $api_key, - agent_id => $o->get('agent-id'), - check_interval => $o->get('check-interval'), + # During initial connection and agent init, wait less time + # 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, + 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; } @@ -4368,24 +4473,31 @@ sub main { # Create and connect a Percona Web API client. sub get_api_client { my (%args) = @_; + have_required_args(\%args,qw( api_key + interval )) or die; - my $api_key = $args{api_key}; + my $api_key = $args{api_key}; + my $interval = $args{interval}; # Optional args my $tries = $args{tries}; - my $wait = $args{wait} || 30; my $client; while ( $oktorun && !$client && (!defined $tries || $tries--) ) { + _info("Connecting to Percona Web Services"); eval { $client = Percona::WebAPI::Client->new( - api_key => $api_key, + api_key => $api_key, ); }; 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 # # ################################ # -# Initialize the agent: if it's new, create it, wait for a config, then run; -# else, get lastest config, then run. +# Initialize the agent, i.e. create and return an Agent resource. +# 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 { my (%args) = @_; have_required_args(\%args, qw( - api_key - check_interval + client + interval )) or die; - my $api_key = $args{api_key}; - my $check_interval = $args{check_interval}; + my $client = $args{client}; + my $interval = $args{interval}; # Optional args my $agent_id = $args{agent_id}; - my $client = $args{client}; my $versions = $args{versions}; - # Get a connected Percona Web API client. - $client ||= get_api_client( - api_key => $api_key, - tries => undef, - wait => $check_interval, - ); + _info('Initializing agent'); # Do a version-check every time the agent starts. If versions # 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 # 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; if ( $agent_id ) { $action = 'put'; @@ -4476,7 +4549,7 @@ sub make_agent { ); while ( $oktorun ) { - _log($action eq 'put' ? "Updating agent $agent_id" + _info($action eq 'put' ? "Updating agent $agent_id" : "Creating new agent $agent_id"); eval { $client->$action( @@ -4484,128 +4557,107 @@ sub make_agent { content => $agent, ); }; - 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; + if ( $EVAL_ERROR ) { + _warn($EVAL_ERROR); + $interval->(); + } + else { + _info("Initialized") + } } 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 { my (%args) = @_; have_required_args(\%args,qw( agent client - check_interval + interval + config_file )) or die; - my $agent = $args{agent_id}; - my $client = $args{client}; - my $check_interval = $args{check_interval}; + my $agent = $args{agent_id}; + my $client = $args{client}; + my $interval = $args{interval}; + my $config_file = $args{config_file}; - _log("Running agent " . $agent->id); + _info('Running agent ' . $agent->id); my $config; my $services; - while ( $oktorun ) { - my $new_config = get_config(); - if ( resource_diff($config, $new_config) ) { - _log('Got new config'); - eval { - write_config(); - }; - if ( $EVAL_ERROR ) { - } - else { + eval { + _info('Getting config'); + my $new_config = $client->get( + url => $client->links->{config}, + ); + if ( resource_diff($config, $new_config) ) { + _info('Got new config'); + write_config( + config => $config, + file => $config_file, + ); $config = $new_config; } + }; + if ( $EVAL_ERROR ) { + _warn($EVAL_ERROR); } - my $new_services = get_services(); - if ( resource_diff($services, $new_services) ) { - _log('Got new services'); - write_services(); - schedule_services(); + if ( $config ) { + eval { + _info('Getting services'); + my $new_services = $client->get( + 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"); - sleep $check_interval if $oktorun; + # If no config yet, the tool's built-in default for + # --check-interval is used instead. + $interval->($config->{'check-interval'}); } return; } - -# Get the agent's config from Percona. There won't be a config until -# the agent has been configured by the customer via the web app. -sub get_config { +# Write a Config resource to a Percona Toolkit config file, +# usually $HOME/pt-agent.conf. +sub write_config { my (%args) = @_; + have_required_args(\%args,qw( - client - check_interval + config + file )) or die; - my $client = $args{client}; - my $check_interval = $args{client}; + my $config = $args{config}; + my $file = $args{file}; - my $config; - while ( $oktorun ) { - _log('Getting config'); - eval { - $config = $client->get( - url => $client->links->{config}, - ); - }; - my $e = $EVAL_ERROR; - last if !$e && $config; # success + _info("Writing new config to $file"); - # Try again - if ( $e ) { - _log("Error: $e"); - } - elsif ( !$config ) { - _log('No config for this agent yet.'); - } - _log("Sleeping $check_interval seconds, then trying again"); - sleep $check_interval if $oktorun; - } + open my $fh, '>', $file + or die "Error opening $file: $OS_ERROR"; + print { $fh } Percona::WebAPI::Representation::as_config($config) + or die "Error writing to $file: $OS_ERROR"; + close $fh + or die "Error closing $file: $OS_ERROR"; - return $config; -} - -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; + return; } # #################### # @@ -4630,13 +4682,29 @@ sub send_data { # ################## # sub _log { - my ($msg) = @_; + my ($level, $msg) = @_; my ($s, $m, $h, $d, $M) = localtime; my $ts = sprintf('%02d-%02dT%02d:%02d:%02d', $M+1, $d, $h, $m, $s); - print "$ts $msg\n"; + print "$ts $level $msg\n"; 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 { return '123'; } diff --git a/lib/HTTP/Mirco.pm b/lib/HTTP/Micro.pm similarity index 56% rename from lib/HTTP/Mirco.pm rename to lib/HTTP/Micro.pm index 90420d65..f5dc472b 100644 --- a/lib/HTTP/Mirco.pm +++ b/lib/HTTP/Micro.pm @@ -1,4 +1,4 @@ -# This program is copyright 2012 Percona Inc. +# 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 @@ -15,23 +15,21 @@ # this program; if not, write to the Free Software Foundation, Inc., 59 Temple # 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 -# implementation +# implementation. +package HTTP::Micro; + +our $VERSION = '0.01'; -package HTTPMicro; -BEGIN { - $HTTPMicro::VERSION = '0.001'; -} use strict; -use warnings; - +use warnings FATAL => 'all'; +use English qw(-no_match_vars); use Carp (); - my @attributes; BEGIN { @attributes = qw(agent timeout); @@ -103,7 +101,7 @@ sub _request { headers => {}, }; - my $handle = HTTPMicro::Handle->new(timeout => $self->{timeout}); + my $handle = HTTP::Micro::Handle->new(timeout => $self->{timeout}); $handle->connect($scheme, $host, $port); @@ -169,322 +167,327 @@ sub _split_url { return ($scheme, $host, $port, $path_query); } -package - HTTPMicro::Handle; # hide from PAUSE/indexers -use strict; -use warnings; +} # HTTP::Micro -use Carp qw[croak]; -use Errno qw[EINTR EPIPE]; -use IO::Socket qw[SOCK_STREAM]; +{ + package HTTP::Micro::Handle; -sub BUFSIZE () { 32768 } + use strict; + use warnings FATAL => 'all'; + use English qw(-no_match_vars); -my $Printable = sub { - local $_ = shift; - s/\r/\\r/g; - s/\n/\\n/g; - s/\t/\\t/g; - s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge; - $_; -}; + use Carp qw(croak); + use Errno qw(EINTR EPIPE); + use IO::Socket qw(SOCK_STREAM); -sub new { - my ($class, %args) = @_; - return bless { - rbuf => '', - timeout => 60, - max_line_size => 16384, - %args - }, $class; -} + sub BUFSIZE () { 32768 } -my $ssl_verify_args = { - check_cn => "when_only", - wildcards_in_alt => "anywhere", - wildcards_in_cn => "anywhere" -}; + my $Printable = sub { + local $_ = shift; + s/\r/\\r/g; + s/\n/\\n/g; + s/\t/\\t/g; + s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge; + $_; + }; -sub connect { - @_ == 4 || croak(q/Usage: $handle->connect(scheme, host, port)/); - my ($self, $scheme, $host, $port) = @_; + sub new { + my ($class, %args) = @_; + return bless { + rbuf => '', + timeout => 60, + max_line_size => 16384, + %args + }, $class; + } - if ( $scheme eq 'https' ) { - 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/); - } + my $ssl_verify_args = { + check_cn => "when_only", + wildcards_in_alt => "anywhere", + wildcards_in_cn => "anywhere" + }; - $self->{fh} = 'IO::Socket::INET'->new( - PeerHost => $host, - PeerPort => $port, - Proto => 'tcp', - Type => SOCK_STREAM, - Timeout => $self->{timeout} - ) or croak(qq/Could not connect to '$host:$port': $@/); + sub connect { + @_ == 4 || croak(q/Usage: $handle->connect(scheme, host, port)/); + my ($self, $scheme, $host, $port) = @_; - binmode($self->{fh}) - or croak(qq/Could not binmode() socket: '$!'/); + if ( $scheme eq 'https' ) { + 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') { - IO::Socket::SSL->start_SSL($self->{fh}); - ref($self->{fh}) eq 'IO::Socket::SSL' - or die(qq/SSL connection failed for $host\n/); - 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; + $self->{fh} = IO::Socket::INET->new( + PeerHost => $host, + PeerPort => $port, + Proto => 'tcp', + Type => SOCK_STREAM, + Timeout => $self->{timeout} + ) or croak(qq/Could not connect to '$host:$port': $@/); - return $self; -} + binmode($self->{fh}) + or croak(qq/Could not binmode() socket: '$!'/); -sub close { - @_ == 1 || croak(q/Usage: $handle->close()/); - my ($self) = @_; - CORE::close($self->{fh}) - or croak(qq/Could not close socket: '$!'/); -} + if ( $scheme eq 'https') { + IO::Socket::SSL->start_SSL($self->{fh}); + ref($self->{fh}) eq 'IO::Socket::SSL' + or die(qq/SSL connection failed for $host\n/); + 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 { - @_ == 2 || croak(q/Usage: $handle->write(buf)/); - my ($self, $buf) = @_; + return $self; + } - my $len = length $buf; - my $off = 0; + sub close { + @_ == 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 () { - $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; -} + my $len = length $buf; + my $off = 0; -sub read { - @_ == 2 || @_ == 3 || croak(q/Usage: $handle->read(len)/); - my ($self, $len) = @_; + local $SIG{PIPE} = 'IGNORE'; - my $buf = ''; - my $got = length $self->{rbuf}; + while () { + $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) { - my $take = ($got < $len) ? $got : $len; - $buf = substr($self->{rbuf}, 0, $take, ''); - $len -= $take; - } + sub read { + @_ == 2 || @_ == 3 || croak(q/Usage: $handle->read(len)/); + my ($self, $len) = @_; - while ($len > 0) { - $self->can_read - 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; -} + my $buf = ''; + my $got = length $self->{rbuf}; -sub readline { - @_ == 1 || croak(q/Usage: $handle->readline()/); - my ($self) = @_; + if ($got) { + my $take = ($got < $len) ? $got : $len; + $buf = substr($self->{rbuf}, 0, $take, ''); + $len -= $take; + } - while () { - 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/); -} + while ($len > 0) { + $self->can_read + 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 read_header_lines { - @_ == 1 || @_ == 2 || croak(q/Usage: $handle->read_header_lines([headers])/); - my ($self, $headers) = @_; - $headers ||= {}; - my $lines = 0; - my $val; + sub readline { + @_ == 1 || croak(q/Usage: $handle->readline()/); + my ($self) = @_; - while () { - my $line = $self->readline; + while () { + 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) { - my ($field_name) = lc $1; - $val = \($headers->{$field_name} = $2); - } - elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) { - $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 read_header_lines { + @_ == 1 || @_ == 2 || croak(q/Usage: $handle->read_header_lines([headers])/); + my ($self, $headers) = @_; + $headers ||= {}; + my $lines = 0; + my $val; -sub write_header_lines { - (@_ == 2 && ref $_[1] eq 'HASH') || croak(q/Usage: $handle->write_header_lines(headers)/); - my($self, $headers) = @_; + while () { + my $line = $self->readline; - my $buf = ''; - 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); -} + if ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) { + my ($field_name) = lc $1; + $val = \($headers->{$field_name} = $2); + } + elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) { + $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 read_content_body { - @_ == 3 || @_ == 4 || croak(q/Usage: $handle->read_content_body(callback, response, [read_length])/); - my ($self, $cb, $response, $len) = @_; - $len ||= $response->{headers}{'content-length'}; + sub write_header_lines { + (@_ == 2 && ref $_[1] eq 'HASH') || croak(q/Usage: $handle->write_header_lines(headers)/); + my($self, $headers) = @_; - croak("No content-length in the returned response, and this " - . "UA doesn't implement chunking") unless defined $len; + my $buf = ''; + 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) { - my $read = ($len > BUFSIZE) ? BUFSIZE : $len; - $cb->($self->read($read), $response); - $len -= $read; - } + sub read_content_body { + @_ == 3 || @_ == 4 || croak(q/Usage: $handle->read_content_body(callback, response, [read_length])/); + my ($self, $cb, $response, $len) = @_; + $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 { - @_ == 2 || croak(q/Usage: $handle->write_content_body(request)/); - my ($self, $request) = @_; - my ($len, $content_length) = (0, $request->{headers}{'content-length'}); + while ($len > 0) { + my $read = ($len > BUFSIZE) ? BUFSIZE : $len; + $cb->($self->read($read), $response); + $len -= $read; + } - $len += $self->write($request->{content}); + return; + } - $len == $content_length - or croak(qq/Content-Length missmatch (got: $len expected: $content_length)/); + sub write_content_body { + @_ == 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 { - @_ == 1 || croak(q/Usage: $handle->read_response_header()/); - my ($self) = @_; + $len == $content_length + or croak(qq/Content-Length missmatch (got: $len expected: $content_length)/); - 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 - or croak(q/Malformed Status-Line: / . $Printable->($line)); + sub read_response_header { + @_ == 1 || croak(q/Usage: $handle->read_response_header()/); + my ($self) = @_; - my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4); + my $line = $self->readline; - return { - status => $status, - reason => $reason, - headers => $self->read_header_lines, - protocol => $protocol, - }; -} + $line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x + or croak(q/Malformed Status-Line: / . $Printable->($line)); -sub write_request_header { - @_ == 4 || croak(q/Usage: $handle->write_request_header(method, request_uri, headers)/); - my ($self, $method, $request_uri, $headers) = @_; + my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4); - return $self->write("$method $request_uri HTTP/1.1\x0D\x0A") - + $self->write_header_lines($headers); -} + return { + status => $status, + reason => $reason, + headers => $self->read_header_lines, + protocol => $protocol, + }; + } -sub _do_timeout { - my ($self, $type, $timeout) = @_; - $timeout = $self->{timeout} - unless defined $timeout && $timeout >= 0; + sub write_request_header { + @_ == 4 || croak(q/Usage: $handle->write_request_header(method, request_uri, headers)/); + my ($self, $method, $request_uri, $headers) = @_; - my $fd = fileno $self->{fh}; - defined $fd && $fd >= 0 - or croak(q/select(2): 'Bad file descriptor'/); + return $self->write("$method $request_uri HTTP/1.1\x0D\x0A") + + $self->write_header_lines($headers); + } - my $initial = time; - my $pending = $timeout; - my $nfound; + sub _do_timeout { + my ($self, $type, $timeout) = @_; + $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 () { - $nfound = ($type eq 'read') - ? select($fdset, undef, undef, $pending) - : 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; -} + my $initial = time; + my $pending = $timeout; + my $nfound; -sub can_read { - @_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_read([timeout])/); - my $self = shift; - return $self->_do_timeout('read', @_) -} + vec(my $fdset = '', $fd, 1) = 1; -sub can_write { - @_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_write([timeout])/); - my $self = shift; - return $self->_do_timeout('write', @_) -} + while () { + $nfound = ($type eq 'read') + ? select($fdset, undef, undef, $pending) + : 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 # 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 = ( 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 )) }, @@ -703,7 +707,6 @@ if ( $INC{"IO/Socket/SSL.pm"} ) { } 1; -} # ########################################################################### # End HTTPMicro package # ########################################################################### diff --git a/lib/Percona/WebAPI/Util.pm b/lib/Percona/WebAPI/Util.pm new file mode 100644 index 00000000..0c3a5dea --- /dev/null +++ b/lib/Percona/WebAPI/Util.pm @@ -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 +# ########################################################################### diff --git a/lib/VersionCheck.pm b/lib/VersionCheck.pm index 84ab5e06..bb761d8e 100644 --- a/lib/VersionCheck.pm +++ b/lib/VersionCheck.pm @@ -40,7 +40,7 @@ use constant PTDEBUG => $ENV{PTDEBUG} || 0; local $EVAL_ERROR; eval { require Percona::Toolkit; - require Percona::HTTP::Micro; + require HTTP::Micro; }; my $dir = File::Spec->tmpdir(); @@ -163,7 +163,7 @@ sub pingback { # Optional args my ($instances, $ua, $vc) = @args{qw(instances ua VersionCheck)}; - $ua ||= HTTPMicro->new( timeout => 5 ); + $ua ||= HTTP::Micro->new( timeout => 5 ); $vc ||= VersionCheck->new(); # GET https://upgrade.percona.com, the server will return diff --git a/t/lib/HTTPMicro.t b/t/lib/HTTP/Micro.t similarity index 85% rename from t/lib/HTTPMicro.t rename to t/lib/HTTP/Micro.t index bf32e40c..703aff53 100644 --- a/t/lib/HTTPMicro.t +++ b/t/lib/HTTP/Micro.t @@ -11,7 +11,7 @@ use warnings FATAL => 'all'; use English qw(-no_match_vars); use Test::More; -use HTTPMicro; +use HTTP::Micro; local $EVAL_ERROR; eval { require HTTP::Tiny }; @@ -22,12 +22,12 @@ if ( $EVAL_ERROR ) { # 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" ) { 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( $micro->{content}, qr/^\Q$tiny->{content}/, - "HTTPMicro == HTTP::Tiny for $test_url" + "HTTP::Micro == HTTP::Tiny for $test_url" ); } diff --git a/t/lib/Percona/WebAPI/Representation.t b/t/lib/Percona/WebAPI/Representation.t new file mode 100644 index 00000000..31ae7f37 --- /dev/null +++ b/t/lib/Percona/WebAPI/Representation.t @@ -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; diff --git a/t/lib/Percona/WebAPI/Util.t b/t/lib/Percona/WebAPI/Util.t new file mode 100644 index 00000000..8f7c779d --- /dev/null +++ b/t/lib/Percona/WebAPI/Util.t @@ -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;