File Coverage

blib/lib/Net/IMP/HTTP/Example/LogFormData.pm
Criterion Covered Total %
statement 21 100 21.0
branch 0 40 0.0
condition 0 16 0.0
subroutine 7 17 41.1
pod 6 9 66.6
total 34 182 18.6


line stmt bran cond sub pod time code
1             # sample IMP plugin to log formulare data
2             # e.q query_string and POST data
3              
4 1     1   60040 use strict;
  1         3  
  1         34  
5 1     1   4 use warnings;
  1         1  
  1         31  
6             package Net::IMP::HTTP::Example::LogFormData;
7 1     1   5 use base 'Net::IMP::HTTP::Connection';
  1         2  
  1         160  
8 1     1   700 no if $] >= 5.017011, warnings => 'experimental::smartmatch';
  1         9  
  1         5  
9              
10             use fields (
11 1         5 'rqbuf', # buffered data from request
12             'req', # HTTP::Request object for request header
13             'info', # collection of infos for logging after request end
14             'btype', # content type from request body, eg.
15             # application/x-www-form-urlencoded or multipart/form-data
16 1     1   73 );
  1         2  
17              
18 1     1   59 use Net::IMP qw(:DEFAULT :log); # constants
  1         2  
  1         209  
19             require HTTP::Request;
20 1     1   5 use Net::IMP::Debug;
  1         1  
  1         11  
21              
22             sub RTYPES {
23             # we don't change anything but need to analyze, so we can PREPASS
24             # everything initially until Inf and later upgrade it to PASS
25             # because we are only interested in request header and body, data
26             # from server can be passed from the beginning
27             return (
28 0     0 0   IMP_PREPASS,
29             IMP_PASS,
30             IMP_DENY, # on parsing errors
31             IMP_LOG, # somewhere to log the info about form data
32             );
33             }
34              
35             sub new_analyzer {
36 0     0 1   my ($class,%args) = @_;
37 0           my $self = $class->SUPER::new_analyzer(%args);
38 0           $self->run_callback(
39             # prepass all from request
40             [ IMP_PREPASS,0,IMP_MAXOFFSET ],
41             # we don't even need to look at response
42             [ IMP_PASS,1,IMP_MAXOFFSET ],
43             );
44 0           return $self;
45             }
46              
47              
48             sub request_hdr {
49 0     0 1   my ($self,$hdr) = @_;
50 0 0         my $req = $self->{req} = HTTP::Request->parse($hdr) or do {
51             # failed to parse
52 0           $self->run_callback(
53             [ IMP_DENY,0,"failed to parse request header" ]);
54 0           return;
55             };
56              
57 0           $self->{rqbuf} = '';
58 0           $self->{info} = undef;
59 0           $self->{btype} = undef;
60              
61 0 0         if ( my @qp = $req->uri->query_form ) {
62             #debug("got query_string @qp");
63 0           my @param;
64 0           for(my $i=0;$i<@qp;$i+=2 ) {
65 0           push @param,[ $qp[$i], $qp[$i+1] ];
66             }
67 0           $self->{info}{'header.query_string'} = \@param
68             }
69              
70 0           my $ct = $req->content_type;
71 0 0 0       if ( $ct && $req->method eq 'POST' and
      0        
72             $ct ~~ ['application/x-www-form-urlencoded','multipart/form-data']
73             ){
74             #debug("got content-type $ct");
75 0           $self->{btype} = $ct;
76             } else {
77             # no need to analyze further
78 0   0       my $len = $req->content_length // 0;
79             #debug("no or no interesting body");
80 0 0         $self->_log_formdata() if $self->{info};
81 0           $self->{rqbuf} = ''; # throw away
82 0           $self->run_callback( [ IMP_PASS,0, $self->offset(0) + $len ]);
83             }
84             }
85              
86             sub request_body {
87 0     0 1   my ($self,$data,$offset) = @_;
88 0 0         $offset and die "gaps should not happen";
89              
90 0 0 0       if (( $data//'') eq '' ) {
    0          
91             # eof
92             # parse body if necessary
93             #debug("eof on $dir");
94 0 0         if ( ! $self->{btype} ) {
    0          
    0          
95             } elsif ( $self->{btype} eq 'application/x-www-form-urlencoded' ) {
96 0           my @param;
97 0           for( split( /\&/,$self->{rqbuf}) ) {
98 0           my ($k,$v) = split('=',$_,2);
99 0           for($k,$v) {
100 0 0         defined($_) or next;
101 0           s{\+}{ }g;
102 0           s{%([\da-fA-F]{2})}{ chr(hex($1)) }esg;
  0            
103             }
104 0           push @param,[$k,$v];
105             }
106 0           $self->{info}{'body.urlencoded'} = \@param;
107            
108             } elsif ( $self->{btype} eq 'multipart/form-data' ) {
109 0           my (undef,$boundary) = $self->{req}->header('content-type')
110             =~m{;\s*boundary=(\"?)([^";,]+)\1}i;
111 0 0         if ( ! $boundary ) {
112 0           $self->run_callback([
113             IMP_DENY,0,
114             "missing boundary for multipart/form-data"
115             ]);
116             }
117             # we might use MIME:: heere, but this would be yet another non-CORE
118             # dependency :(
119             # this is quick and dirty and we just skip param on errors, but
120             # this is just a demo!
121 0           my @param;
122 0           for my $part ( split(
123             m{^--\Q$boundary\E(?:--)?\r?\n}m,
124             $self->{rqbuf} )) {
125 0 0         $part =~m{\A(.*?(\r?\n))\2(.*)}s or next;
126 0           my ($hdr,$v) = ($1,$3);
127             my ($cd) = $hdr =~m{^Content-Disposition:[ \t]*(.*(?:\r?\n[ \t].*)*)}mi
128 0 0         or do {
129 0           debug("no content-disposition in multipart header: $hdr");
130 0           next;
131             };
132 0           $cd =~s{\r?\n}{}g;
133 0   0       my $name = $cd =~m{;\s*name=(?:\"([^\"]+)\"|([^\s\";]+))} && ($1||$2);
134 0 0         $name or do {
135 0           debug("no name in content-disposition in multipart header: $hdr");
136 0           next;
137             };
138 0   0       my $fname = $cd =~m{;\s*filename=(?:\"([^\"]+)\"|([^\s\";]+))} && ($1||$2);
139 0           $v =~s{\r?\n\Z}{};
140 0 0         $v = "UPLOAD:$fname (".length($v)." bytes)" if $fname; # don't display content of file
141 0           push @param, [$name,$v];
142             }
143 0           $self->{info}{'body.multipart'} = \@param;
144             } else {
145             # should not happen, we set btype only if we can handle the type
146 0           die "unhandled POST content-type $self->{btype}"
147             }
148 0           $self->_log_formdata();
149              
150             } elsif ( $self->{btype} ) {
151             # add to buf to analyze later
152 0           $self->{rqbuf} .= $data;
153             }
154             }
155              
156             # these should not be reached
157 0     0 1   sub response_hdr {}
158 0     0 1   sub response_body {}
159 0     0 1   sub any_data {}
160 0     0 0   sub chunk_header {}
161 0     0 0   sub chunk_trailer {}
162              
163             sub _log_formdata {
164 0     0     my $self = shift;
165 0 0         my $info = $self->{info} or return;
166             # report form information if any, preferable as YAML, but fall back to
167             # Data::Dumper, which is in core
168 0           my $text;
169 0 0         if ( eval { require YAML } ) {
  0 0          
    0          
170 0           $text = YAML::Dump($info)
171 0           } elsif ( eval { require YAML::Tiny } ) {
172 0           $text = YAML::Tiny::Dump($info)
173 0           } elsif ( eval { require Data::Dumper }) {
174 0           $text = Data::Dumper->new([$info])->Terse(1)->Dump;
175             } else {
176             # Data::Dumper is perl core!
177 0           die "WTF, not even Data::Dumper is installed?";
178             }
179 0           $self->run_callback([ IMP_LOG,0,0,0,IMP_LOG_INFO,$text ]);
180 0           $self->{info} = undef;
181             }
182              
183             __END__