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