487 lines
15 KiB
Perl
487 lines
15 KiB
Perl
|
#!/usr/bin/perl
|
||
|
|
package JMX::Jmx4Perl::Agent;
|
||
|
|
|
||
|
|
use JSON;
|
||
|
|
use URI::Escape qw(uri_escape_utf8);
|
||
|
|
use HTTP::Request;
|
||
|
|
use Carp;
|
||
|
|
use strict;
|
||
|
|
use vars qw($VERSION $DEBUG);
|
||
|
|
use base qw(JMX::Jmx4Perl);
|
||
|
|
use JMX::Jmx4Perl::Request;
|
||
|
|
use JMX::Jmx4Perl::Response;
|
||
|
|
use JMX::Jmx4Perl::Agent::UserAgent;
|
||
|
|
use Data::Dumper;
|
||
|
|
|
||
|
|
|
||
|
|
$VERSION = $JMX::Jmx4Perl::VERSION;
|
||
|
|
|
||
|
|
=head1 NAME
|
||
|
|
|
||
|
|
JMX::Jmx4Perl::Agent - JSON-HTTP based acess to a remote JMX agent
|
||
|
|
|
||
|
|
=head1 SYNOPSIS
|
||
|
|
|
||
|
|
my $agent = new JMX::Jmx4Perl(mode=>"agent", url => "http://jeeserver/j4p");
|
||
|
|
my $answer = $agent->get_attribute("java.lang:type=Memory","HeapMemoryUsage");
|
||
|
|
print Dumper($answer);
|
||
|
|
|
||
|
|
{
|
||
|
|
request => {
|
||
|
|
attribute => "HeapMemoryUsage",
|
||
|
|
name => "java.lang:type=Memory"
|
||
|
|
},
|
||
|
|
status => 200,
|
||
|
|
value => {
|
||
|
|
committed => 18292736,
|
||
|
|
init => 0,
|
||
|
|
max => 532742144,
|
||
|
|
used => 15348352
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
=head1 DESCRIPTION
|
||
|
|
|
||
|
|
This module is not used directly, but via L<JMX::Jmx4Perl>, which acts as a
|
||
|
|
proxy to this module. You can think of L<JMX::Jmx4Perl> as the interface which
|
||
|
|
is backed up by this module. Other implementations (e.g.
|
||
|
|
|
||
|
|
=head1 METHODS
|
||
|
|
|
||
|
|
=over 4
|
||
|
|
|
||
|
|
=item $jjagent = JMX::Jmx4Perl::Agent->new(url => $url, ....)
|
||
|
|
|
||
|
|
Creates a new local agent for a given url
|
||
|
|
|
||
|
|
=over
|
||
|
|
|
||
|
|
=item url => <url to JEE server>
|
||
|
|
|
||
|
|
The url where the agent is deployed. This is a mandatory parameter. The url
|
||
|
|
must include the context within the server, which is typically based on the
|
||
|
|
name of the war archive. Example: C<http://localhost:8080/j4p> for a drop
|
||
|
|
in deployment of the agent in a standard Tomcat's webapp directory.
|
||
|
|
|
||
|
|
=item timeout => <timeout>
|
||
|
|
|
||
|
|
Timeout in seconds after which a request should be stopped if it not suceeds
|
||
|
|
within this time. This parameter is given through directly to the underlying
|
||
|
|
L<LWP::UserAgent>
|
||
|
|
|
||
|
|
=item user => <user>, password => <password>
|
||
|
|
|
||
|
|
Credentials to use for the HTTP request
|
||
|
|
|
||
|
|
=item method => <method>
|
||
|
|
|
||
|
|
The HTTP method to use for contacting the agent. Must be either "GET" or
|
||
|
|
"POST". This method is used, if the request to send dosen't specify the method
|
||
|
|
and no other parameters forces a POST context.
|
||
|
|
|
||
|
|
=item proxy => { http => '<http_proxy>', https => '<https_proxy>', ... }
|
||
|
|
|
||
|
|
=item proxy => <http_proxy>
|
||
|
|
|
||
|
|
=item proxy => { url => <http_proxy> }
|
||
|
|
|
||
|
|
Optional proxy to use
|
||
|
|
|
||
|
|
=item proxy_user => <user>, proxy_password => <password>
|
||
|
|
|
||
|
|
Credentials to use for accessing the proxy
|
||
|
|
|
||
|
|
=item target
|
||
|
|
|
||
|
|
Add a target which is used for any request served by this object if not already
|
||
|
|
a target is present in the request. This way you can setup the default target
|
||
|
|
configuration if you are using the agent servlet as a proxy, e.g.
|
||
|
|
|
||
|
|
... target => { url => "service:jmx:...", user => "...", password => "..." }
|
||
|
|
|
||
|
|
=item legacy-escape
|
||
|
|
|
||
|
|
Before version 1.0 a quite strange escaping scheme is used, when the part of a
|
||
|
|
GET requests contains a slash (/). Starting with 1.0 this scheme has changed,
|
||
|
|
but in order to allow post 1.0 Jmx4perl clients acess pre 1.0 Jolokia agents,
|
||
|
|
this option can be set to true to switch to the old escape mechanism.
|
||
|
|
|
||
|
|
=back
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
# HTTP Parameters to be used for transmitting the request
|
||
|
|
my @PARAMS = ("maxDepth","maxCollectionSize","maxObjects","ignoreErrors");
|
||
|
|
|
||
|
|
# Regexp for detecting invalid chars which can not be used securily in pathinfos
|
||
|
|
my $INVALID_PATH_CHARS = qr/%(5C|3F|3B|2F)/i; # \ ? ; /
|
||
|
|
|
||
|
|
# Init called by parent package within 'new' for specific initialization. See
|
||
|
|
# above for the parameters recognized
|
||
|
|
sub init {
|
||
|
|
my $self = shift;
|
||
|
|
|
||
|
|
croak "No URL provided" unless $self->cfg('url');
|
||
|
|
my $ua = JMX::Jmx4Perl::Agent::UserAgent->new();
|
||
|
|
$ua->jjagent_config($self->{cfg});
|
||
|
|
#push @{ $ua->requests_redirectable }, 'POST';
|
||
|
|
$ua->timeout($self->cfg('timeout')) if $self->cfg('timeout');
|
||
|
|
#print "TO: ",$ua->timeout(),"\n";
|
||
|
|
$ua->agent("JMX::Jmx4Perl::Agent $VERSION");
|
||
|
|
# $ua->env_proxy;
|
||
|
|
my $proxy = $self->cfg('proxy');
|
||
|
|
if ($proxy) {
|
||
|
|
my $url = ref($proxy) eq "HASH" ? $proxy->{url} : $proxy;
|
||
|
|
if (ref($url) eq "HASH") {
|
||
|
|
for my $k (keys %$url) {
|
||
|
|
$ua->proxy($k,$url->{$k});
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
if ($self->cfg('url') =~ m|^(.*?)://|) {
|
||
|
|
# Set proxy for URL scheme used
|
||
|
|
$ua->proxy($1,$url);
|
||
|
|
} else {
|
||
|
|
$ua->proxy('http',$proxy);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
$self->{ua} = $ua;
|
||
|
|
return $self;
|
||
|
|
}
|
||
|
|
|
||
|
|
=item $url = $agent->url()
|
||
|
|
|
||
|
|
Get the base URL for connecting to the agent. You cannot change the URL via this
|
||
|
|
method, it is immutable for a given agent.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub url {
|
||
|
|
my $self = shift;
|
||
|
|
return $self->cfg('url');
|
||
|
|
}
|
||
|
|
|
||
|
|
=item $resp = $agent->request($request)
|
||
|
|
|
||
|
|
Implementation of the JMX request as specified in L<JMX::Jmx4Perl>. It uses a
|
||
|
|
L<HTTP::Request> sent via an L<LWP::UserAgent> for posting a JSON representation
|
||
|
|
of the request. This method shouldn't be called directly but via
|
||
|
|
L<JMX::Jmx4Perl>->request().
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub request {
|
||
|
|
my $self = shift;
|
||
|
|
my @jmx_requests = $self->cfg('target') ? $self->_update_targets(@_) : @_;
|
||
|
|
my $ua = $self->{ua};
|
||
|
|
my $http_req = $self->_to_http_request(@jmx_requests);
|
||
|
|
if ($self->{cfg}->{verbose}) {
|
||
|
|
print $http_req->as_string;
|
||
|
|
print "===========================================================\n";
|
||
|
|
}
|
||
|
|
#print Dumper($http_req);
|
||
|
|
my $http_resp = $ua->request($http_req);
|
||
|
|
my $json_resp = {};
|
||
|
|
if ($self->{cfg}->{verbose}) {
|
||
|
|
print $http_resp->as_string,"\n";
|
||
|
|
print "===========================================================\n";
|
||
|
|
}
|
||
|
|
eval {
|
||
|
|
$json_resp = from_json($http_resp->content());
|
||
|
|
};
|
||
|
|
my $json_error = $@;
|
||
|
|
if ($http_resp->is_error) {
|
||
|
|
return JMX::Jmx4Perl::Response->new
|
||
|
|
(
|
||
|
|
status => $http_resp->code,
|
||
|
|
value => $json_error ? $http_resp->content : $json_resp,
|
||
|
|
error => $json_error ? $self->_prepare_http_error_text($http_resp) :
|
||
|
|
ref($json_resp) eq "ARRAY" ? join "\n", map { $_->{error} } grep { $_->{error} } @$json_resp : $json_resp->{error},
|
||
|
|
stacktrace => ref($json_resp) eq "ARRAY" ? $self->_extract_stacktraces($json_resp) : $json_resp->{stacktrace},
|
||
|
|
request => @jmx_requests == 1 ? $jmx_requests[0] : \@jmx_requests
|
||
|
|
);
|
||
|
|
} elsif ($json_error) {
|
||
|
|
# If is not an HTTP-Error and deserialization fails, then we
|
||
|
|
# probably got a wrong URL and get delivered some server side
|
||
|
|
# document (with HTTP code 200)
|
||
|
|
my $e = $json_error;
|
||
|
|
$e =~ s/(.*)at .*?line.*$/$1/;
|
||
|
|
return JMX::Jmx4Perl::Response->new
|
||
|
|
(
|
||
|
|
status => 400,
|
||
|
|
error =>
|
||
|
|
"Error while deserializing JSON answer (Wrong URL ?)\n" . $e,
|
||
|
|
value => $http_resp->content
|
||
|
|
);
|
||
|
|
}
|
||
|
|
|
||
|
|
my @responses = ($self->_from_http_response($json_resp,@jmx_requests));
|
||
|
|
if (!wantarray && scalar(@responses) == 1) {
|
||
|
|
return shift @responses;
|
||
|
|
} else {
|
||
|
|
return @responses;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
=item $encrypted = $agent->encrypt($plain)
|
||
|
|
|
||
|
|
Encrypt a password which can be used in configuration files in order to
|
||
|
|
obfuscate the clear text password.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub encrypt {
|
||
|
|
return "[[" . &JMX::Jmx4Perl::Agent::UserAgent::encrypt(shift) . "]]";
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# Create an HTTP-Request for calling the server
|
||
|
|
sub _to_http_request {
|
||
|
|
my $self = shift;
|
||
|
|
my @reqs = @_;
|
||
|
|
if ($self->_use_GET_request(\@reqs)) {
|
||
|
|
# Old, rest-style
|
||
|
|
my $url = $self->request_url($reqs[0]);
|
||
|
|
return HTTP::Request->new(GET => $url);
|
||
|
|
} else {
|
||
|
|
my $url = $self->cfg('url') || croak "No URL provided";
|
||
|
|
$url .= "/" unless $url =~ m|/$|;
|
||
|
|
my $request = HTTP::Request->new(POST => $url);
|
||
|
|
my $content = to_json(@reqs > 1 ? \@reqs : $reqs[0], { convert_blessed => 1 });
|
||
|
|
#print Dumper($reqs[0],$content);
|
||
|
|
$request->content($content);
|
||
|
|
return $request;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _use_GET_request {
|
||
|
|
my $self = shift;
|
||
|
|
my $reqs = shift;
|
||
|
|
if (@$reqs == 1) {
|
||
|
|
my $req = $reqs->[0];
|
||
|
|
# For proxy configs and explicite set POST request, get can not be
|
||
|
|
# used
|
||
|
|
return 0 if defined($req->get("target"));
|
||
|
|
#print Dumper($req);
|
||
|
|
for my $r ($req->method,$self->cfg('method')) {
|
||
|
|
return lc($r) eq "get" if defined($r);
|
||
|
|
}
|
||
|
|
# GET by default
|
||
|
|
return 1;
|
||
|
|
} else {
|
||
|
|
return 0;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# Create one or more response objects for a given request
|
||
|
|
sub _from_http_response {
|
||
|
|
my $self = shift;
|
||
|
|
my $json_resp = shift;
|
||
|
|
my @reqs = @_;
|
||
|
|
if (ref($json_resp) eq "HASH") {
|
||
|
|
return JMX::Jmx4Perl::Response->new(%{$json_resp},request => $reqs[0]);
|
||
|
|
} elsif (ref($json_resp) eq "ARRAY") {
|
||
|
|
die "Internal: Number of request and responses doesn't match (",scalar(@reqs)," vs. ",scalar(@$json_resp)
|
||
|
|
unless scalar(@reqs) == scalar(@$json_resp);
|
||
|
|
|
||
|
|
my @ret = ();
|
||
|
|
for (my $i=0;$i<@reqs;$i++) {
|
||
|
|
die "Internal: Not a hash --> ",$json_resp->[$i] unless ref($json_resp->[$i]) eq "HASH";
|
||
|
|
my $response = JMX::Jmx4Perl::Response->new(%{$json_resp->[$i]},request => $reqs[$i]);
|
||
|
|
push @ret,$response;
|
||
|
|
}
|
||
|
|
return @ret;
|
||
|
|
} else {
|
||
|
|
die "Internal: Not a hash nor an array but ",ref($json_resp) ? ref($json_resp) : $json_resp;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# Update targets if not set in request.
|
||
|
|
sub _update_targets {
|
||
|
|
my $self = shift;
|
||
|
|
my @requests = @_;
|
||
|
|
my $target = $self->_clone_target;
|
||
|
|
for my $req (@requests) {
|
||
|
|
$req->{target} = $target unless exists($req->{target});
|
||
|
|
# A request with existing but undefined target removes
|
||
|
|
# any default
|
||
|
|
delete $req->{target} unless defined($req->{target});
|
||
|
|
}
|
||
|
|
return @requests;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _clone_target {
|
||
|
|
my $self = shift;
|
||
|
|
die "Internal: No target set" unless $self->cfg('target');
|
||
|
|
my $target = { %{$self->cfg('target')} };
|
||
|
|
if ($target->{env}) {
|
||
|
|
$target->{env} = { %{$target->{env}}};
|
||
|
|
}
|
||
|
|
return $target;
|
||
|
|
}
|
||
|
|
|
||
|
|
=item $url = $agent->request_url($request)
|
||
|
|
|
||
|
|
Generate the URL for accessing the java agent based on a given request.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub request_url {
|
||
|
|
my $self = shift;
|
||
|
|
my $request = shift;
|
||
|
|
my $url = $self->cfg('url') || croak "No base url given in configuration";
|
||
|
|
$url .= "/" unless $url =~ m|/$|;
|
||
|
|
|
||
|
|
my $type = $request->get("type");
|
||
|
|
my $req = $type . "/";
|
||
|
|
$req .= $self->_escape($request->get("mbean"));
|
||
|
|
|
||
|
|
if ($type eq READ) {
|
||
|
|
$req .= "/" . $self->_escape($request->get("attribute"));
|
||
|
|
$req .= $self->_extract_path($request->get("path"));
|
||
|
|
} elsif ($type eq WRITE) {
|
||
|
|
$req .= "/" . $self->_escape($request->get("attribute"));
|
||
|
|
$req .= "/" . $self->_escape($self->_null_escape($request->get("value")));
|
||
|
|
$req .= $self->_extract_path($request->get("path"));
|
||
|
|
} elsif ($type eq LIST) {
|
||
|
|
$req .= $self->_extract_path($request->get("path"));
|
||
|
|
} elsif ($type eq EXEC) {
|
||
|
|
$req .= "/" . $self->_escape($request->get("operation"));
|
||
|
|
for my $arg (@{$request->get("arguments")}) {
|
||
|
|
# Array refs are sticked together via ","
|
||
|
|
my $a = ref($arg) eq "ARRAY" ? join ",",@{$arg} : $arg;
|
||
|
|
$req .= "/" . $self->_escape($self->_null_escape($a));
|
||
|
|
}
|
||
|
|
} elsif ($type eq SEARCH) {
|
||
|
|
# Nothing further to append.
|
||
|
|
}
|
||
|
|
# Squeeze multiple slashes
|
||
|
|
$req =~ s|((?:!/)?/)/*|$1|g;
|
||
|
|
#print "R: $req\n";
|
||
|
|
|
||
|
|
if ($req =~ $INVALID_PATH_CHARS || $request->{use_query}) {
|
||
|
|
$req = "?p=$req";
|
||
|
|
}
|
||
|
|
my @params;
|
||
|
|
for my $k (@PARAMS) {
|
||
|
|
push @params, $k . "=" . $request->get($k)
|
||
|
|
if $request->get($k);
|
||
|
|
}
|
||
|
|
$req .= ($req =~ /\?/ ? "&" : "?") . join("&",@params) if @params;
|
||
|
|
return $url . $req;
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# =============================================================================
|
||
|
|
|
||
|
|
|
||
|
|
# Return an (optional) path which must already be escaped
|
||
|
|
sub _extract_path {
|
||
|
|
my $self = shift;
|
||
|
|
my $path = shift;
|
||
|
|
return $path ? "/" . $path : "";
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# Escaping is simple:
|
||
|
|
# ! --> !!
|
||
|
|
# / --> !/
|
||
|
|
# It is not done by backslashes '\' since often they get magically get
|
||
|
|
# translated into / when part of an URL
|
||
|
|
sub _escape {
|
||
|
|
my $self = shift;
|
||
|
|
my $input = shift;
|
||
|
|
if ($self->cfg('legacy-escape')) {
|
||
|
|
# Pre 1.0 escaping:
|
||
|
|
$input =~ s|(/+)|"/" . ('-' x length($1)) . "/"|eg;
|
||
|
|
$input =~ s|^/-|/^|; # The first slash needs to be escaped (first)
|
||
|
|
$input =~ s|-/$|+/|; # as well as last slash. They need a special
|
||
|
|
# escape, because two subsequent slashes get
|
||
|
|
# squeezed to one on the server side
|
||
|
|
|
||
|
|
} else {
|
||
|
|
# Simpler escaping since 1.0:
|
||
|
|
$input =~ s/!/!!/g;
|
||
|
|
$input =~ s/\//!\//g;
|
||
|
|
}
|
||
|
|
|
||
|
|
return URI::Escape::uri_escape_utf8($input,"^A-Za-z0-9\-_.!~*'()/"); # Added "/" to
|
||
|
|
# default
|
||
|
|
# set. See L<URI>
|
||
|
|
}
|
||
|
|
|
||
|
|
# Escape empty and undef values so that they can be detangled
|
||
|
|
# on the server side
|
||
|
|
sub _null_escape {
|
||
|
|
my $self = shift;
|
||
|
|
my $value = shift;
|
||
|
|
if (!defined($value)) {
|
||
|
|
return "[null]";
|
||
|
|
} elsif (! length($value)) {
|
||
|
|
return "\"\"";
|
||
|
|
} else {
|
||
|
|
return $value;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# Prepare some readable error text
|
||
|
|
sub _prepare_http_error_text {
|
||
|
|
my $self = shift;
|
||
|
|
my $http_resp = shift;
|
||
|
|
my $content = $http_resp->content;
|
||
|
|
my $error = "Error while fetching ".$http_resp->request->uri." :\n\n" . $http_resp->status_line . "\n";
|
||
|
|
chomp $content;
|
||
|
|
if ($content && $content ne $http_resp->status_line) {
|
||
|
|
my $error .= "=" x length($http_resp->status_line) . "\n\n";
|
||
|
|
my $short = substr($content,0,600);
|
||
|
|
$error .= $short . (length($short) < length($content) ? "\n\n... [truncated] ...\n\n" : "") . "\n"
|
||
|
|
}
|
||
|
|
return $error;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Extract all stacktraces stored in the given array ref of json responses
|
||
|
|
sub _extract_stacktraces {
|
||
|
|
my $self = shift;
|
||
|
|
my $json_resp = shift;
|
||
|
|
my @ret = ();
|
||
|
|
for my $j (@$json_resp) {
|
||
|
|
push @ret,$j->{stacktrace} if $j->{stacktrace};
|
||
|
|
}
|
||
|
|
return @ret ? (scalar(@ret) == 1 ? $ret[0] : \@ret) : undef;
|
||
|
|
}
|
||
|
|
|
||
|
|
=back
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
# ===================================================================
|
||
|
|
# Specialized UserAgent for passing in credentials:
|
||
|
|
|
||
|
|
=head1 LICENSE
|
||
|
|
|
||
|
|
This file is part of jmx4perl.
|
||
|
|
|
||
|
|
Jmx4perl 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, either version 2 of the License, or
|
||
|
|
(at your option) any later version.
|
||
|
|
|
||
|
|
jmx4perl is distributed in the hope that it will be useful,
|
||
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
|
|
GNU General Public License for more details.
|
||
|
|
|
||
|
|
You should have received a copy of the GNU General Public License
|
||
|
|
along with jmx4perl. If not, see <http://www.gnu.org/licenses/>.
|
||
|
|
|
||
|
|
A commercial license is available as well. Please contact roland@cpan.org for
|
||
|
|
further details.
|
||
|
|
|
||
|
|
=head1 AUTHOR
|
||
|
|
|
||
|
|
roland@cpan.org
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
1;
|