File Coverage

blib/lib/PerlGuard/Agent/Monitors/NetHTTP.pm
Criterion Covered Total %
statement 15 54 27.7
branch 0 10 0.0
condition 0 6 0.0
subroutine 5 13 38.4
pod 0 6 0.0
total 20 89 22.4


line stmt bran cond sub pod time code
1             package PerlGuard::Agent::Monitors::NetHTTP;
2 1     1   1319 use Moo;
  1         1  
  1         5  
3 1     1   251 use Data::Dumper;
  1         2  
  1         54  
4 1     1   736 use PerlGuard::Agent::LexWrap;
  1         2  
  1         4  
5 1     1   5 use Time::HiRes;
  1         2  
  1         8  
6 1     1   100 use Scalar::Util qw(blessed);
  1         1  
  1         577  
7             extends 'PerlGuard::Agent::Monitors';
8              
9             has requests_in_progress => ( is => 'rw', default => sub { {} });
10              
11             sub die_unless_suitable {
12 0 0   0 0   eval 'use Net::HTTP::Methods; use LWP::UserAgent; 1' or die "Could not load modules required for NetHTTP monitoring";
13             }
14              
15              
16             sub start_monitoring {
17 0     0 0   my $self = shift;
18              
19 0           my $simple_request_wrapper = wrap 'LWP::UserAgent::simple_request', pre => $self->simple_request_wrapper_sub();
20 0           my $simple_response_wrapper = wrap 'LWP::UserAgent::simple_request', post => $self->simple_response_wrapper_sub();
21              
22 0           push(@{$self->overrides}, $simple_request_wrapper);
  0            
23 0           push(@{$self->overrides}, $simple_response_wrapper);
  0            
24              
25             }
26              
27             sub stop_monitoring {
28 0     0 0   my $self = shift;
29              
30 0           foreach my $override(@{$self->overrides}) {
  0            
31 0           undef $override;
32             }
33              
34             }
35              
36             sub inform_agent_of_event {
37 0     0 0   my $self = shift;
38 0           my $trace = shift;
39              
40 0           $self->agent->add_webservice_transaction($trace);
41              
42             }
43              
44             sub simple_response_wrapper_sub {
45 0     0 0   my $self = shift;
46              
47             return sub {
48 0     0     my $request = $_[1];
49 0           my $response = $_[4];
50              
51 0           my $request_id = $request->header('X-PerlGuard-Auto-Track');
52              
53 0 0         return unless $request_id;
54 0           my $trace = $self->requests_in_progress->{$request_id};
55 0 0         unless($trace) {
56             #warn "Could not find a transaction trace matching the request\n";
57 0           return;
58             }
59              
60 0           $trace->{finish_time} = [Time::HiRes::gettimeofday()];
61 0           $trace->{status_code} = $response->code();
62 0           $trace->{status_message} = $response->message();
63              
64 0           $self->inform_agent_of_event($trace);
65              
66 0           delete $self->requests_in_progress->{$request_id};
67              
68             }
69              
70              
71 0           }
72              
73             # What we want to do is stash a unique value in a header so that we can
74             # A) Link this up with its response later
75             # B) Use it as the unique ID for cross application tracing
76             sub simple_request_wrapper_sub {
77 0     0 0   my $self = shift;
78              
79             return sub {
80              
81             #Determine if we are ok to log
82              
83 0 0 0 0     unless($self && $self->agent && $self->agent->current_profile()) {
      0        
84             #warn "Could not associate HTTP request with a profile, perhaps this request happened outside of the request";
85 0           return;
86             }
87              
88 0           my $profile = $self->agent->current_profile();
89              
90 0           my $request = $_[0]->[1];
91 0           my $request_id = $profile->generate_new_cross_application_tracing_id();
92              
93 0           $request->header( 'X-PerlGuard-Auto-Track' => $request_id );
94              
95 0 0         my $uri = blessed($request->uri) ? $request->uri->as_string : $request->uri;
96              
97 0           $self->requests_in_progress->{$request_id} = {
98             cross_application_tracing_id => $request_id,
99             start_time => [Time::HiRes::gettimeofday()],
100             uri => $uri,
101             method => $request->method,
102             };
103              
104             }
105 0           }
106              
107             1;
108