← Back to branch summary

~percona-toolkit-dev/percona-toolkit/fix-change-master-bug-932614

« back to all changes in this revision

Viewing changes to lib/HTTPProtocolParser.pm

  • Committer: Daniel Nichter
  • Date: 2011-06-24 17:22:06 UTC
  • Revision ID: daniel@percona.com-20110624172206-c7q4s4ad6r260zz6
Add lib/, t/lib/, and sandbox/.  All modules are updated and passing on MySQL 5.1.

Show diffs side-by-side

added added

removed removed

Lines of Context:
lib/HTTPProtocolParser.pm
 
1
# This program is copyright 2009-2011 Percona Inc.
 
2
# Feedback and improvements are welcome.
 
3
#
 
4
# THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
 
5
# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
 
6
# MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
 
7
#
 
8
# This program is free software; you can redistribute it and/or modify it under
 
9
# the terms of the GNU General Public License as published by the Free Software
 
10
# Foundation, version 2; OR the Perl Artistic License.  On UNIX and similar
 
11
# systems, you can issue `man perlgpl' or `man perlartistic' to read these
 
12
# licenses.
 
13
#
 
14
# You should have received a copy of the GNU General Public License along with
 
15
# this program; if not, write to the Free Software Foundation, Inc., 59 Temple
 
16
# Place, Suite 330, Boston, MA  02111-1307  USA.
 
17
# ###########################################################################
 
18
# HTTPProtocolParser package $Revision: 5811 $
 
19
# ###########################################################################
 
20
 
 
21
# Package: HTTPProtocolParser
 
22
# HTTPProtocolParser parses HTTP traffic from tcpdump files.
 
23
{
 
24
package HTTPProtocolParser;
 
25
use base 'ProtocolParser';
 
26
 
 
27
use strict;
 
28
use warnings FATAL => 'all';
 
29
use English qw(-no_match_vars);
 
30
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
 
31
 
 
32
# server is the "host:port" of the sever being watched.  It's auto-guessed if
 
33
# not specified.
 
34
sub new {
 
35
   my ( $class, %args ) = @_;
 
36
   my $self = $class->SUPER::new(
 
37
      %args,
 
38
      port => 80,
 
39
   );
 
40
   return $self;
 
41
}
 
42
 
 
43
# Handles a packet from the server given the state of the session.  Returns an
 
44
# event if one was ready to be created, otherwise returns nothing.
 
45
sub _packet_from_server {
 
46
   my ( $self, $packet, $session, $misc ) = @_;
 
47
   die "I need a packet"  unless $packet;
 
48
   die "I need a session" unless $session;
 
49
 
 
50
   MKDEBUG && _d('Packet is from server; client state:', $session->{state}); 
 
51
 
 
52
   # If there's no session state, then we're catching a server response
 
53
   # mid-stream.
 
54
   if ( !$session->{state} ) {
 
55
      MKDEBUG && _d('Ignoring mid-stream server response');
 
56
      return;
 
57
   }
 
58
 
 
59
   if ( $session->{out_of_order} ) {
 
60
      # We're waiting for the header so we can get the content length.
 
61
      # Once we know this, we can determine how many out of order packets
 
62
      # we need to complete the request, then order them and re-process.
 
63
      my ($line1, $content);
 
64
      if ( !$session->{have_header} ) {
 
65
         ($line1, $content) = $self->_parse_header(
 
66
            $session, $packet->{data}, $packet->{data_len});
 
67
      }
 
68
      if ( $line1 ) {
 
69
         $session->{have_header} = 1;
 
70
         $packet->{content_len}  = length $content;
 
71
         MKDEBUG && _d('Got out of order header with',
 
72
            $packet->{content_len}, 'bytes of content');
 
73
      }
 
74
      my $have_len = $packet->{content_len} || $packet->{data_len};
 
75
      map { $have_len += $_->{data_len} }
 
76
         @{$session->{packets}};
 
77
      $session->{have_all_packets}
 
78
         = 1 if $session->{attribs}->{bytes}
 
79
                && $have_len >= $session->{attribs}->{bytes};
 
80
      MKDEBUG && _d('Have', $have_len, 'of', $session->{attribs}->{bytes});
 
81
      return;
 
82
   }
 
83
 
 
84
   # Assume that the server is returning only one value. 
 
85
   # TODO: make it handle multiple.
 
86
   if ( $session->{state} eq 'awaiting reply' ) {
 
87
 
 
88
      # Save this early because we may return early if the packets
 
89
      # are being received out of order.  Also, save it only once
 
90
      # in case we re-process packets if they're out of order.
 
91
      $session->{start_reply} = $packet->{ts} unless $session->{start_reply};
 
92
 
 
93
      # Get first line of header and first chunk of contents/data.
 
94
      my ($line1, $content) = $self->_parse_header($session, $packet->{data},
 
95
            $packet->{data_len});
 
96
 
 
97
      # The reponse, when in order, is text header followed by data.
 
98
      # If there's no line1, then we didn't get the text header first
 
99
      # which means we're getting the response in out of order packets.
 
100
      if ( !$line1 ) {
 
101
         $session->{out_of_order}     = 1;  # alert parent
 
102
         $session->{have_all_packets} = 0;
 
103
         return;
 
104
      }
 
105
 
 
106
      # First line should be: version  code phrase
 
107
      # E.g.:                 HTTP/1.1  200 OK
 
108
      my ($version, $code, $phrase) = $line1 =~ m/(\S+)/g;
 
109
      $session->{attribs}->{Status_code} = $code;
 
110
      MKDEBUG && _d('Status code for last', $session->{attribs}->{arg},
 
111
         'request:', $session->{attribs}->{Status_code});
 
112
 
 
113
      my $content_len = $content ? length $content : 0;
 
114
      MKDEBUG && _d('Got', $content_len, 'bytes of content');
 
115
      if ( $session->{attribs}->{bytes}
 
116
           && $content_len < $session->{attribs}->{bytes} ) {
 
117
         $session->{data_len}  = $session->{attribs}->{bytes};
 
118
         $session->{buff}      = $content;
 
119
         $session->{buff_left} = $session->{attribs}->{bytes} - $content_len;
 
120
         MKDEBUG && _d('Contents not complete,', $session->{buff_left},
 
121
            'bytes left');
 
122
         $session->{state} = 'recving content';
 
123
         return;
 
124
      }
 
125
   }
 
126
   elsif ( $session->{state} eq 'recving content' ) {
 
127
      if ( $session->{buff} ) {
 
128
         MKDEBUG && _d('Receiving content,', $session->{buff_left},
 
129
            'bytes left');
 
130
         return;
 
131
      }
 
132
      MKDEBUG && _d('Contents received');
 
133
   }
 
134
   else {
 
135
      # TODO:
 
136
      warn "Server response in unknown state"; 
 
137
      return;
 
138
   }
 
139
 
 
140
   MKDEBUG && _d('Creating event, deleting session');
 
141
   $session->{end_reply} = $session->{ts_max} || $packet->{ts};
 
142
   my $event = $self->make_event($session, $packet);
 
143
   delete $self->{sessions}->{$session->{client}}; # http is stateless!
 
144
   return $event;
 
145
}
 
146
 
 
147
# Handles a packet from the client given the state of the session.
 
148
sub _packet_from_client {
 
149
   my ( $self, $packet, $session, $misc ) = @_;
 
150
   die "I need a packet"  unless $packet;
 
151
   die "I need a session" unless $session;
 
152
 
 
153
   MKDEBUG && _d('Packet is from client; state:', $session->{state});
 
154
 
 
155
   my $event;
 
156
   if ( ($session->{state} || '') =~ m/awaiting / ) {
 
157
      MKDEBUG && _d('More client headers:', $packet->{data});
 
158
      return;
 
159
   }
 
160
 
 
161
   if ( !$session->{state} ) {
 
162
      $session->{state} = 'awaiting reply';
 
163
      my ($line1, undef) = $self->_parse_header($session, $packet->{data}, $packet->{data_len});
 
164
      # First line should be: request page      version
 
165
      # E.g.:                 GET     /foo.html HTTP/1.1
 
166
      my ($request, $page, $version) = $line1 =~ m/(\S+)/g;
 
167
      if ( !$request || !$page ) {
 
168
         MKDEBUG && _d("Didn't get a request or page:", $request, $page);
 
169
         return;
 
170
      }
 
171
      $request = lc $request;
 
172
      my $vh   = $session->{attribs}->{Virtual_host} || '';
 
173
      my $arg = "$request $vh$page";
 
174
      MKDEBUG && _d('arg:', $arg);
 
175
 
 
176
      if ( $request eq 'get' || $request eq 'post' ) {
 
177
         @{$session->{attribs}}{qw(arg)} = ($arg);
 
178
      }
 
179
      else {
 
180
         MKDEBUG && _d("Don't know how to handle a", $request, "request");
 
181
         return;
 
182
      }
 
183
 
 
184
      $session->{start_request}         = $packet->{ts};
 
185
      $session->{attribs}->{host}       = $packet->{src_host};
 
186
      $session->{attribs}->{pos_in_log} = $packet->{pos_in_log};
 
187
      $session->{attribs}->{ts}         = $packet->{ts};
 
188
   }
 
189
   else {
 
190
      # TODO:
 
191
      die "Probably multiple GETs from client before a server response?"; 
 
192
   }
 
193
 
 
194
   return $event;
 
195
}
 
196
 
 
197
sub _parse_header {
 
198
   my ( $self, $session, $data, $len, $no_recurse ) = @_;
 
199
   die "I need data" unless $data;
 
200
   my ($header, $content)    = split(/\r\n\r\n/, $data);
 
201
   my ($line1, $header_vals) = $header  =~ m/\A(\S+ \S+ .+?)\r\n(.+)?/s;
 
202
   MKDEBUG && _d('HTTP header:', $line1);
 
203
   return unless $line1;
 
204
 
 
205
   if ( !$header_vals ) {
 
206
      MKDEBUG && _d('No header vals');
 
207
      return $line1, undef;
 
208
   }
 
209
   my @headers;
 
210
   foreach my $val ( split(/\r\n/, $header_vals) ) {
 
211
      last unless $val;
 
212
      # Capture and save any useful header values.
 
213
      MKDEBUG && _d('HTTP header:', $val);
 
214
      if ( $val =~ m/^Content-Length/i ) {
 
215
         ($session->{attribs}->{bytes}) = $val =~ /: (\d+)/;
 
216
         MKDEBUG && _d('Saved Content-Length:', $session->{attribs}->{bytes});
 
217
      }
 
218
      if ( $val =~ m/Content-Encoding/i ) {
 
219
         ($session->{compressed}) = $val =~ /: (\w+)/;
 
220
         MKDEBUG && _d('Saved Content-Encoding:', $session->{compressed});
 
221
      }
 
222
      if ( $val =~ m/^Host/i ) {
 
223
         # The "host" attribute is already taken, so we call this "domain".
 
224
         ($session->{attribs}->{Virtual_host}) = $val =~ /: (\S+)/;
 
225
         MKDEBUG && _d('Saved Host:', ($session->{attribs}->{Virtual_host}));
 
226
      }
 
227
   }
 
228
   return $line1, $content;
 
229
}
 
230
 
 
231
sub _d {
 
232
   my ($package, undef, $line) = caller 0;
 
233
   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
 
234
        map { defined $_ ? $_ : 'undef' }
 
235
        @_;
 
236
   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
 
237
}
 
238
 
 
239
1;
 
240
}
 
241
# ###########################################################################
 
242
# End HTTPProtocolParser package
 
243
# ###########################################################################