1#!/usr/bin/perl 2package JMX::Jmx4Perl::Agent; 3 4use JSON; 5use URI::Escape qw(uri_escape_utf8); 6use HTTP::Request; 7use Carp; 8use strict; 9use vars qw($VERSION $DEBUG); 10use base qw(JMX::Jmx4Perl); 11use JMX::Jmx4Perl::Request; 12use JMX::Jmx4Perl::Response; 13use JMX::Jmx4Perl::Agent::UserAgent; 14use Data::Dumper; 15 16 17$VERSION = $JMX::Jmx4Perl::VERSION; 18 19=head1 NAME 20 21JMX::Jmx4Perl::Agent - JSON-HTTP based acess to a remote JMX agent 22 23=head1 SYNOPSIS 24 25 my $agent = new JMX::Jmx4Perl(mode=>"agent", url => "http://jeeserver/j4p"); 26 my $answer = $agent->get_attribute("java.lang:type=Memory","HeapMemoryUsage"); 27 print Dumper($answer); 28 29 { 30 request => { 31 attribute => "HeapMemoryUsage", 32 name => "java.lang:type=Memory" 33 }, 34 status => 200, 35 value => { 36 committed => 18292736, 37 init => 0, 38 max => 532742144, 39 used => 15348352 40 } 41 } 42 43=head1 DESCRIPTION 44 45This module is not used directly, but via L<JMX::Jmx4Perl>, which acts as a 46proxy to this module. You can think of L<JMX::Jmx4Perl> as the interface which 47is backed up by this module. Other implementations (e.g. 48 49=head1 METHODS 50 51=over 4 52 53=item $jjagent = JMX::Jmx4Perl::Agent->new(url => $url, ....) 54 55Creates a new local agent for a given url 56 57=over 58 59=item url => <url to JEE server> 60 61The url where the agent is deployed. This is a mandatory parameter. The url 62must include the context within the server, which is typically based on the 63name of the war archive. Example: C<http://localhost:8080/j4p> for a drop 64in deployment of the agent in a standard Tomcat's webapp directory. 65 66=item timeout => <timeout> 67 68Timeout in seconds after which a request should be stopped if it not suceeds 69within this time. This parameter is given through directly to the underlying 70L<LWP::UserAgent> 71 72=item user => <user>, password => <password> 73 74Credentials to use for the HTTP request 75 76=item method => <method> 77 78The HTTP method to use for contacting the agent. Must be either "GET" or 79"POST". This method is used, if the request to send dosen't specify the method 80and no other parameters forces a POST context. 81 82=item proxy => { http => '<http_proxy>', https => '<https_proxy>', ... } 83 84=item proxy => <http_proxy> 85 86=item proxy => { url => <http_proxy> } 87 88Optional proxy to use 89 90=item proxy_user => <user>, proxy_password => <password> 91 92Credentials to use for accessing the proxy 93 94=item target 95 96Add a target which is used for any request served by this object if not already 97a target is present in the request. This way you can setup the default target 98configuration if you are using the agent servlet as a proxy, e.g. 99 100 ... target => { url => "service:jmx:...", user => "...", password => "..." } 101 102=item legacy-escape 103 104Before version 1.0 a quite strange escaping scheme is used, when the part of a 105GET requests contains a slash (/). Starting with 1.0 this scheme has changed, 106but in order to allow post 1.0 Jmx4perl clients acess pre 1.0 Jolokia agents, 107this option can be set to true to switch to the old escape mechanism. 108 109=back 110 111=cut 112 113# HTTP Parameters to be used for transmitting the request 114my @PARAMS = ("maxDepth","maxCollectionSize","maxObjects","ignoreErrors"); 115 116# Regexp for detecting invalid chars which can not be used securily in pathinfos 117my $INVALID_PATH_CHARS = qr/%(5C|3F|3B|2F)/i; # \ ? ; / 118 119# Init called by parent package within 'new' for specific initialization. See 120# above for the parameters recognized 121sub init { 122 my $self = shift; 123 124 croak "No URL provided" unless $self->cfg('url'); 125 my $ua = JMX::Jmx4Perl::Agent::UserAgent->new(); 126 $ua->jjagent_config($self->{cfg}); 127 #push @{ $ua->requests_redirectable }, 'POST'; 128 $ua->timeout($self->cfg('timeout')) if $self->cfg('timeout'); 129 #print "TO: ",$ua->timeout(),"\n"; 130 $ua->agent("JMX::Jmx4Perl::Agent $VERSION"); 131 # $ua->env_proxy; 132 my $proxy = $self->cfg('proxy'); 133 if ($proxy) { 134 my $url = ref($proxy) eq "HASH" ? $proxy->{url} : $proxy; 135 if (ref($url) eq "HASH") { 136 for my $k (keys %$url) { 137 $ua->proxy($k,$url->{$k}); 138 } 139 } else { 140 if ($self->cfg('url') =~ m|^(.*?)://|) { 141 # Set proxy for URL scheme used 142 $ua->proxy($1,$url); 143 } else { 144 $ua->proxy('http',$proxy); 145 } 146 } 147 } 148 $self->{ua} = $ua; 149 return $self; 150} 151 152=item $url = $agent->url() 153 154Get the base URL for connecting to the agent. You cannot change the URL via this 155method, it is immutable for a given agent. 156 157=cut 158 159sub url { 160 my $self = shift; 161 return $self->cfg('url'); 162} 163 164=item $resp = $agent->request($request) 165 166Implementation of the JMX request as specified in L<JMX::Jmx4Perl>. It uses a 167L<HTTP::Request> sent via an L<LWP::UserAgent> for posting a JSON representation 168of the request. This method shouldn't be called directly but via 169L<JMX::Jmx4Perl>->request(). 170 171=cut 172 173sub request { 174 my $self = shift; 175 my @jmx_requests = $self->cfg('target') ? $self->_update_targets(@_) : @_; 176 my $ua = $self->{ua}; 177 my $http_req = $self->_to_http_request(@jmx_requests); 178 if ($self->{cfg}->{verbose}) { 179 print $http_req->as_string; 180 print "===========================================================\n"; 181 } 182 #print Dumper($http_req); 183 my $http_resp = $ua->request($http_req); 184 my $json_resp = {}; 185 if ($self->{cfg}->{verbose}) { 186 print $http_resp->as_string,"\n"; 187 print "===========================================================\n"; 188 } 189 eval { 190 $json_resp = from_json($http_resp->content()); 191 }; 192 my $json_error = $@; 193 if ($http_resp->is_error) { 194 return JMX::Jmx4Perl::Response->new 195 ( 196 status => $http_resp->code, 197 value => $json_error ? $http_resp->content : $json_resp, 198 error => $json_error ? $self->_prepare_http_error_text($http_resp) : 199 ref($json_resp) eq "ARRAY" ? join "\n", map { $_->{error} } grep { $_->{error} } @$json_resp : $json_resp->{error}, 200 stacktrace => ref($json_resp) eq "ARRAY" ? $self->_extract_stacktraces($json_resp) : $json_resp->{stacktrace}, 201 request => @jmx_requests == 1 ? $jmx_requests[0] : \@jmx_requests 202 ); 203 } elsif ($json_error) { 204 # If is not an HTTP-Error and deserialization fails, then we 205 # probably got a wrong URL and get delivered some server side 206 # document (with HTTP code 200) 207 my $e = $json_error; 208 $e =~ s/(.*)at .*?line.*$/$1/; 209 return JMX::Jmx4Perl::Response->new 210 ( 211 status => 400, 212 error => 213 "Error while deserializing JSON answer (Wrong URL ?)\n" . $e, 214 value => $http_resp->content 215 ); 216 } 217 218 my @responses = ($self->_from_http_response($json_resp,@jmx_requests)); 219 if (!wantarray && scalar(@responses) == 1) { 220 return shift @responses; 221 } else { 222 return @responses; 223 } 224} 225 226=item $encrypted = $agent->encrypt($plain) 227 228Encrypt a password which can be used in configuration files in order to 229obfuscate the clear text password. 230 231=cut 232 233sub encrypt { 234 return "[[" . &JMX::Jmx4Perl::Agent::UserAgent::encrypt(shift) . "]]"; 235} 236 237 238# Create an HTTP-Request for calling the server 239sub _to_http_request { 240 my $self = shift; 241 my @reqs = @_; 242 if ($self->_use_GET_request(\@reqs)) { 243 # Old, rest-style 244 my $url = $self->request_url($reqs[0]); 245 return HTTP::Request->new(GET => $url); 246 } else { 247 my $url = $self->cfg('url') || croak "No URL provided"; 248 $url .= "/" unless $url =~ m|/$|; 249 my $request = HTTP::Request->new(POST => $url); 250 my $content = to_json(@reqs > 1 ? \@reqs : $reqs[0], { convert_blessed => 1 }); 251 #print Dumper($reqs[0],$content); 252 $request->content($content); 253 return $request; 254 } 255} 256 257sub _use_GET_request { 258 my $self = shift; 259 my $reqs = shift; 260 if (@$reqs == 1) { 261 my $req = $reqs->[0]; 262 # For proxy configs and explicite set POST request, get can not be 263 # used 264 return 0 if defined($req->get("target")); 265 #print Dumper($req); 266 for my $r ($req->method,$self->cfg('method')) { 267 return lc($r) eq "get" if defined($r); 268 } 269 # GET by default 270 return 1; 271 } else { 272 return 0; 273 } 274} 275 276# Create one or more response objects for a given request 277sub _from_http_response { 278 my $self = shift; 279 my $json_resp = shift; 280 my @reqs = @_; 281 if (ref($json_resp) eq "HASH") { 282 return JMX::Jmx4Perl::Response->new(%{$json_resp},request => $reqs[0]); 283 } elsif (ref($json_resp) eq "ARRAY") { 284 die "Internal: Number of request and responses doesn't match (",scalar(@reqs)," vs. ",scalar(@$json_resp) 285 unless scalar(@reqs) == scalar(@$json_resp); 286 287 my @ret = (); 288 for (my $i=0;$i<@reqs;$i++) { 289 die "Internal: Not a hash --> ",$json_resp->[$i] unless ref($json_resp->[$i]) eq "HASH"; 290 my $response = JMX::Jmx4Perl::Response->new(%{$json_resp->[$i]},request => $reqs[$i]); 291 push @ret,$response; 292 } 293 return @ret; 294 } else { 295 die "Internal: Not a hash nor an array but ",ref($json_resp) ? ref($json_resp) : $json_resp; 296 } 297} 298 299# Update targets if not set in request. 300sub _update_targets { 301 my $self = shift; 302 my @requests = @_; 303 my $target = $self->_clone_target; 304 for my $req (@requests) { 305 $req->{target} = $target unless exists($req->{target}); 306 # A request with existing but undefined target removes 307 # any default 308 delete $req->{target} unless defined($req->{target}); 309 } 310 return @requests; 311} 312 313sub _clone_target { 314 my $self = shift; 315 die "Internal: No target set" unless $self->cfg('target'); 316 my $target = { %{$self->cfg('target')} }; 317 if ($target->{env}) { 318 $target->{env} = { %{$target->{env}}}; 319 } 320 return $target; 321} 322 323=item $url = $agent->request_url($request) 324 325Generate the URL for accessing the java agent based on a given request. 326 327=cut 328 329sub request_url { 330 my $self = shift; 331 my $request = shift; 332 my $url = $self->cfg('url') || croak "No base url given in configuration"; 333 $url .= "/" unless $url =~ m|/$|; 334 335 my $type = $request->get("type"); 336 my $req = $type . "/"; 337 $req .= $self->_escape($request->get("mbean")); 338 339 if ($type eq READ) { 340 $req .= "/" . $self->_escape($request->get("attribute")); 341 $req .= $self->_extract_path($request->get("path")); 342 } elsif ($type eq WRITE) { 343 $req .= "/" . $self->_escape($request->get("attribute")); 344 $req .= "/" . $self->_escape($self->_null_escape($request->get("value"))); 345 $req .= $self->_extract_path($request->get("path")); 346 } elsif ($type eq LIST) { 347 $req .= $self->_extract_path($request->get("path")); 348 } elsif ($type eq EXEC) { 349 $req .= "/" . $self->_escape($request->get("operation")); 350 for my $arg (@{$request->get("arguments")}) { 351 # Array refs are sticked together via "," 352 my $a = ref($arg) eq "ARRAY" ? join ",",@{$arg} : $arg; 353 $req .= "/" . $self->_escape($self->_null_escape($a)); 354 } 355 } elsif ($type eq SEARCH) { 356 # Nothing further to append. 357 } 358 # Squeeze multiple slashes 359 $req =~ s|((?:!/)?/)/*|$1|g; 360 #print "R: $req\n"; 361 362 if ($req =~ $INVALID_PATH_CHARS || $request->{use_query}) { 363 $req = "?p=$req"; 364 } 365 my @params; 366 for my $k (@PARAMS) { 367 push @params, $k . "=" . $request->get($k) 368 if $request->get($k); 369 } 370 $req .= ($req =~ /\?/ ? "&" : "?") . join("&",@params) if @params; 371 return $url . $req; 372} 373 374 375# ============================================================================= 376 377 378# Return an (optional) path which must already be escaped 379sub _extract_path { 380 my $self = shift; 381 my $path = shift; 382 return $path ? "/" . $path : ""; 383} 384 385 386# Escaping is simple: 387# ! --> !! 388# / --> !/ 389# It is not done by backslashes '\' since often they get magically get 390# translated into / when part of an URL 391sub _escape { 392 my $self = shift; 393 my $input = shift; 394 if ($self->cfg('legacy-escape')) { 395 # Pre 1.0 escaping: 396 $input =~ s|(/+)|"/" . ('-' x length($1)) . "/"|eg; 397 $input =~ s|^/-|/^|; # The first slash needs to be escaped (first) 398 $input =~ s|-/$|+/|; # as well as last slash. They need a special 399 # escape, because two subsequent slashes get 400 # squeezed to one on the server side 401 402 } else { 403 # Simpler escaping since 1.0: 404 $input =~ s/!/!!/g; 405 $input =~ s/\//!\//g; 406 } 407 408 return URI::Escape::uri_escape_utf8($input,"^A-Za-z0-9\-_.!~*'()/"); # Added "/" to 409 # default 410 # set. See L<URI> 411} 412 413# Escape empty and undef values so that they can be detangled 414# on the server side 415sub _null_escape { 416 my $self = shift; 417 my $value = shift; 418 if (!defined($value)) { 419 return "[null]"; 420 } elsif (! length($value)) { 421 return "\"\""; 422 } else { 423 return $value; 424 } 425} 426 427# Prepare some readable error text 428sub _prepare_http_error_text { 429 my $self = shift; 430 my $http_resp = shift; 431 my $content = $http_resp->content; 432 my $error = "Error while fetching ".$http_resp->request->uri." :\n\n" . $http_resp->status_line . "\n"; 433 chomp $content; 434 if ($content && $content ne $http_resp->status_line) { 435 my $error .= "=" x length($http_resp->status_line) . "\n\n"; 436 my $short = substr($content,0,600); 437 $error .= $short . (length($short) < length($content) ? "\n\n... [truncated] ...\n\n" : "") . "\n" 438 } 439 return $error; 440} 441 442# Extract all stacktraces stored in the given array ref of json responses 443sub _extract_stacktraces { 444 my $self = shift; 445 my $json_resp = shift; 446 my @ret = (); 447 for my $j (@$json_resp) { 448 push @ret,$j->{stacktrace} if $j->{stacktrace}; 449 } 450 return @ret ? (scalar(@ret) == 1 ? $ret[0] : \@ret) : undef; 451} 452 453=back 454 455=cut 456 457# =================================================================== 458# Specialized UserAgent for passing in credentials: 459 460=head1 LICENSE 461 462This file is part of jmx4perl. 463 464Jmx4perl is free software: you can redistribute it and/or modify 465it under the terms of the GNU General Public License as published by 466the Free Software Foundation, either version 2 of the License, or 467(at your option) any later version. 468 469jmx4perl is distributed in the hope that it will be useful, 470but WITHOUT ANY WARRANTY; without even the implied warranty of 471MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 472GNU General Public License for more details. 473 474You should have received a copy of the GNU General Public License 475along with jmx4perl. If not, see <http://www.gnu.org/licenses/>. 476 477A commercial license is available as well. Please contact roland@cpan.org for 478further details. 479 480=head1 AUTHOR 481 482roland@cpan.org 483 484=cut 485 4861; 487