File Coverage

blib/lib/Plack/Middleware/Recorder.pm
Criterion Covered Total %
statement 104 113 92.0
branch 25 32 78.1
condition 2 5 40.0
subroutine 18 18 100.0
pod 3 3 100.0
total 152 171 88.8


line stmt bran cond sub pod time code
1             ## no critic (RequireUseStrict)
2             package Plack::Middleware::Recorder;
3             $Plack::Middleware::Recorder::VERSION = '0.05'; # TRIAL
4             ## use critic (RequireUseStrict)
5 11     11   47651 use strict;
  11         17  
  11         310  
6 11     11   38 use warnings;
  11         14  
  11         257  
7 11     11   38 use parent 'Plack::Middleware';
  11         10  
  11         57  
8              
9 11     11   535 use Carp qw(croak);
  11         13  
  11         453  
10 11     11   387 use HTTP::Request;
  11         13309  
  11         109  
11 11     11   861 use IO::File;
  11         1309  
  11         1237  
12 11     11   4300 use IO::String;
  11         17985  
  11         120  
13 11     11   886 use Sereal qw(encode_sereal);
  11         702  
  11         446  
14 11     11   45 use Fcntl qw(:flock);
  11         9  
  11         1092  
15 11     11   4145 use Scope::Guard;
  11         3408  
  11         364  
16 11     11   816 use namespace::clean;
  11         20331  
  11         65  
17              
18 11     11   3769 use Plack::Util::Accessor qw/active start_url stop_url/;
  11         13  
  11         73  
19              
20             sub prepare_app {
21 27     27 1 72325 my ( $self ) = @_;
22              
23 27 100       72 $self->active(1) unless defined $self->active;
24 27 100       1115 $self->start_url('/recorder/start') unless defined $self->start_url;
25 27 100       191 $self->stop_url('/recorder/stop') unless defined $self->stop_url;
26              
27 27         201 my $output = delete $self->{'output'};
28 27 100       69 croak "output parameter required" unless defined $output;
29              
30 26 50       51 if (ref $output) {
31 0         0 $self->{'output_fh'} = $output;
32 0         0 $output->autoflush(1);
33             } else {
34 26 50       410 unless(-w $output) {
35 0         0 croak "$output is not writable";
36             }
37 26         73 $self->{'output_filename'} = $output;
38             }
39             }
40              
41             sub _output_fh {
42 36     36   50 my ( $self, $env ) = @_;
43 36 100       99 unless ($self->{'output_fh'}) {
44 25 100       61 my $mode = $env->{'psgi.run_once'} ? 'a' : 'w';
45 25         127 $self->{'output_fh'} = IO::File->new($self->{'output_filename'}, $mode);
46 25         2107 $self->{'output_fh'}->autoflush(1);
47             }
48 36         830 return $self->{'output_fh'};
49             }
50              
51             sub env_to_http_request {
52 36     36 1 45 my ( $self, $env ) = @_;
53              
54 36         119 my $request = HTTP::Request->new;
55 36         973 $request->method($env->{'REQUEST_METHOD'});
56 36         215 $request->uri($env->{'REQUEST_URI'});
57 36         1235 $request->header(Content_Length => $env->{'CONTENT_LENGTH'});
58 36         1167 $request->header(Content_Type => $env->{'CONTENT_TYPE'});
59 36         1032 foreach my $header (grep { /^HTTP_/ } keys %$env) {
  880         684  
60 44         319 my $value = $env->{$header};
61 44         95 $header =~ s/^HTTP_//;
62 44         66 $header = uc($header);
63 44         103 $header =~ s/\b([a-z])/uc $!/ge;
  0         0  
64              
65 44         93 $request->header($header, $value);
66             }
67              
68 36         1028 my $input = $env->{'psgi.input'};
69 36         162 my $body = IO::String->new;
70 36         1048 my $buffer = '';
71 36         161 while($input->read($buffer, 1024) > 0) {
72 5         44 print $body $buffer;
73             }
74              
75 36         401 $body->setpos(0);
76 36         298 $env->{'psgi.input'} = $body;
77 36         42 $request->content(${ $body->string_ref });
  36         72  
78              
79 36         684 return $request;
80             }
81              
82             sub call {
83 58     58 1 173623 my ( $self, $env ) = @_;
84              
85 58         185 my $app = $self->app;
86 58         278 my $start_url = $self->start_url;
87 58         211 my $stop_url = $self->stop_url;
88 58         174 my $path = $env->{'PATH_INFO'};
89              
90 58         81 $env->{__PACKAGE__ . '.start_url'} = $start_url;
91 58         77 $env->{__PACKAGE__ . '.stop_url'} = $stop_url;
92              
93 58 100       422 if($path =~ m!\Q$start_url\E!) {
    100          
    100          
94 4         18 $self->active(1);
95 4         18 $env->{__PACKAGE__ . '.active'} = $self->active;
96             return [
97 4         34 200,
98             ['Content-Type' => 'text/plain'],
99             [ 'Request recording is ON' ],
100             ];
101             } elsif($path =~ m!\Q$stop_url\E!) {
102 7         18 $self->active(0);
103 7         37 $env->{__PACKAGE__ . '.active'} = $self->active;
104             return [
105 7         62 200,
106             ['Content-Type' => 'text/plain'],
107             [ 'Request recording is OFF' ],
108             ];
109             } elsif($self->active) {
110 36         176 my $req = $self->env_to_http_request($env);
111 36         530 my $frozen = encode_sereal($req);
112              
113 36         94 my $fh = $self->_output_fh($env);
114             # $guard looks unused, but it's unlocking the file upon its
115             # destruction
116 36         71 my $guard = $self->_create_concurrency_lock($fh, $env);
117 36 50       82 if($guard) {
118 36         279 $fh->write(pack('Na*', length($frozen), $frozen));
119 36         3519 $fh->flush;
120             }
121             }
122              
123 47         154 $env->{__PACKAGE__ . '.active'} = $self->active;
124              
125 47         271 return $app->($env);
126             }
127              
128             sub _create_concurrency_lock {
129 36     36   49 my ( $self, $fh, $env ) = @_;
130              
131 36 100 66     164 return 1 if !$env->{'psgi.multithread'} && !$env->{'psgi.multiprocess'};
132              
133 2 50       4 my $locked = eval { flock($fh, LOCK_EX) || die "$!\n" };
  2         21  
134              
135 2 50       5 if(!$locked) {
136 0 0       0 if(my $log = $env->{'psgix.logger'}) {
137 0   0     0 my $error = $@ || 'Unknown error';
138 0         0 chomp $error;
139              
140 0         0 $log->({
141             level => 'warn',
142             message => "Unable to lock filehandle in multiprocess environment ($error); skipping recording",
143             });
144             }
145 0         0 return;
146             }
147              
148 2     2   22 return Scope::Guard->new( sub { flock($fh, LOCK_UN) });
  2         50  
149             }
150              
151             1;
152              
153             # ABSTRACT: Plack middleware that records your client-server interactions
154              
155             __END__