lib/AnyEvent/HTTPD/HTTPConnection.pm

   1 package AnyEvent::HTTPD::HTTPConnection;
   2 use IO::Handle;
   3 use HTTP::Date;
   4 use AnyEvent::Handle;
   5 use Object::Event;
   6 use strict;
   7 no warnings;
   8
   9 our @ISA = qw/Object::Event/;
  10
  11 =head1 NAME
  12
  13 AnyEvent::HTTPD::HTTPConnection - A simple HTTP connection for request and response handling
  14
  15 =head1 DESCRIPTION
  16
  17 This class is a helper class for L<AnyEvent:HTTPD::HTTPServer> and L<AnyEvent::HTTPD>,
  18 it handles TCP reading and writing as well as parsing and serializing
  19 http requests.
  20
  21 It has no public interface yet.
  22
  23 =head1 COPYRIGHT & LICENSE
  24
  25 Copyright 2008 Robin Redeker, all rights reserved.
  26
  27 This program is free software; you can redistribute it and/or modify it
  28 under the same terms as Perl itself.
  29
  30 =cut
  31
  32 sub new {
  33    my $this  = shift;
  34    my $class = ref($this) || $this;
  35    my $self  = { @_ };
  36    bless $self, $class;
  37
  38    $self->{hdl} =
  39       AnyEvent::Handle->new (
  40          fh => $self->{fh},
  41          on_eof => sub {
  42             $self->event ('disconnect');
  43             delete $self->{handles}->{$_[0]}
  44          },
  45          on_error => sub {
  46             $self->event ('disconnect', "Error: $!");
  47             delete $self->{handles}->{$_[0]}
  48          },
  49          on_read => sub {
  50             $self->{rbuf} .= $_[0]->rbuf;
  51             $_[0]->rbuf = '';
  52             $self->handle_data (\$self->{rbuf});
  53             1
  54          }
  55       );
  56
  57    return $self
  58 }
  59
  60
  61 sub error {
  62    my ($self, $code, $msg, $hdr, $content) = @_;
  63
  64    if ($code !~ /^(1\d\d|204|304)$/) {
  65       unless (defined $content) { $content = "$code $msg" }
  66       $hdr->{'Content-Type'} = 'text/plain';
  67    }
  68
  69    $self->response ($code, $msg, $hdr, $content);
  70 }
  71
  72 sub response {
  73    my ($self, $code, $msg, $hdr, $content) = @_;
  74    my $res = "HTTP/1.0 $code $msg\015\012";
  75    $hdr->{'Expires'} = $hdr->{'Date'} = time2str time;
  76    $hdr->{'Cache-Control'} = "max-age=0";
  77    $hdr->{'Content-Length'} = length $content;
  78
  79    while (my ($h, $v) = each %$hdr) {
  80       $res .= "$h: $v\015\012";
  81    }
  82    $res .= "\015\012";
  83    $res .= $content;
  84    $self->{hdl}->push_write ($res);
  85    $self->{hdl}->on_drain (sub { $self->do_disconnect; });
  86 }
  87
  88 sub _unquote {
  89    my ($str) = @_;
  90    if ($str =~ /^"(.*?)"$/) {
  91       $str = $1;
  92       my $obo = '';
  93       while ($str =~ s/^(?:([^"]+)|\\(.))//s) {
  94         $obo .= $1;
  95       }
  96       $str = $obo;
  97    }
  98    $str
  99 }
 100
 101
 102 # FIXME: (or test if this is the case)
 103 # 09 01:21:32 <schmorp> header der art
 104 # 09 01:21:40 <schmorp> "   xxx   :bbbb" werden nicht geparsed oder?
 105 # 09 01:21:56 <schmorp> also,d as istd er header xxx
 106 sub _parse_headers {
 107    my ($header) = @_;
 108    my $hdr;
 109
 110    while ($header =~ /\G
 111       ([^:\000-\040]+) : [\011\040]*
 112          ((?:[^\015\012]+|\015\012[\011\040])* )
 113          \015\012
 114       /sgx) {
 115
 116       $hdr->{$1} .= ",$2"
 117    }
 118    for (keys %$hdr) { $hdr->{$_} = substr $hdr->{$_}, 1; }
 119    $hdr
 120 }
 121
 122 sub decode_part {
 123    my ($self, $hdr, $cont) = @_;
 124
 125    $hdr = _parse_headers ($hdr);
 126    if ($hdr->{'Content-Disposition'} =~ /form-data/) {
 127       my ($dat, $name_para) = split /\s*;\s*/, $hdr->{'Content-Disposition'};
 128       my ($name, $par) = split /\s*=\s*/, $name_para;
 129       if ($par =~ /^".*"$/) { $par = _unquote ($par) }
 130       return ($par, $cont, $hdr->{'Content-Type'});
 131    }
 132    ();
 133 }
 134
 135 sub decode_multipart {
 136    my ($self, $cont, $boundary) = @_;
 137
 138    my $parts = {};
 139
 140    while ($cont =~ s/
 141       ^--\Q$boundary\E              \015\012
 142       ((?:[^\015\012]+\015\012)* ) \015\012
 143       (.*?) \015\012
 144       (--\Q$boundary\E (--)?  \015\012)
 145       /\3/xs) {
 146       my ($h, $c, $e) = ($1, $2, $3);
 147
 148       if (my (@p) = $self->decode_part ($h, $c)) {
 149          push @{$parts->{$p[0]}}, [$p[1], $p[2], $p[3]];
 150       }
 151
 152       last if $e eq '--';
 153    }
 154    return $parts;
 155 }
 156
 157 # application/x-www-form-urlencoded
 158 #
 159 # This is the default content type. Forms submitted with this content type must
 160 # be encoded as follows:
 161 #
 162 #    1. Control names and values are escaped. Space characters are replaced by
 163 #    `+', and then reserved characters are escaped as described in [RFC1738],
 164 #    section 2.2: Non-alphanumeric characters are replaced by `%HH', a percent
 165 #    sign and two hexadecimal digits representing the ASCII code of the
 166 #    character. Line breaks are represented as "CR LF" pairs (i.e., `%0D%0A').
 167 #
 168 #    2. The control names/values are listed in the order they appear in the
 169 #    document. The name is separated from the value by `=' and name/value pairs
 170 #    are separated from each other by `&'.
 171 #
 172
 173 sub _url_unescape {
 174    my ($val) = @_;
 175    $val =~ s/\+/ /g;
 176    $val =~ s/%([0-9a-f][0-9a-f])/chr (hex ($1))/eg;
 177    $val
 178 }
 179
 180 sub parse_urlencoded {
 181    my ($self, $cont) = @_;
 182    my (@pars) = split /\&/, $cont;
 183    $cont = {};
 184
 185    for (@pars) {
 186       my ($name, $val) = split /=/, $_;
 187       $name = _url_unescape ($name);
 188       $val  = _url_unescape ($val);
 189
 190       push @{$cont->{$name}}, [$val, ''];
 191    }
 192    $cont
 193 }
 194
 195 sub handle_request {
 196    my ($self, $method, $uri, $hdr, $cont) = @_;
 197
 198    my ($c, @params) = split /\s*;\s*/, $hdr->{'Content-Type'};
 199    my $bound;
 200    for (@params) {
 201       if (/^\s*boundary\s*=\s*(.*?)\s*$/) {
 202          $bound = _unquote ($1);
 203       }
 204    }
 205
 206    if ($c eq 'multipart/form-data') {
 207       $cont = $self->decode_multipart ($cont, $bound);
 208
 209    } elsif ($c =~ /x-www-form-urlencoded/) {
 210       $cont = $self->parse_urlencoded ($cont);
 211    }
 212
 213    $self->event (request => $method, $uri, $hdr, $cont);
 214 }
 215
 216 sub handle_data {
 217    my ($self, $rbuf) = @_;
 218
 219    if ($self->{content_len}) {
 220       if ($self->{content_len} <= length $$rbuf) {
 221          my $cont = substr $$rbuf, 0, $self->{content_len};
 222          $$rbuf = substr $$rbuf, $self->{content_len};
 223          $self->handle_request (@{delete $self->{last_header}}, $cont);
 224          delete $self->{content_len};
 225       }
 226
 227    } else {
 228       if ($$rbuf =~ s/^
 229              (\S+) \040 (\S+) \040 HTTP\/(\d+)\.(\d+) \015\012
 230              ((?:[^\015]+\015\012)* ) \015\012//sx) {
 231
 232          my ($m, $u, $vm, $vi, $h) = ($1,$2,$3,$4,$5);
 233          my $hdr = {};
 234
 235          if ($m ne 'GET' && $m ne 'HEAD' && $m ne 'POST') {
 236             $self->error (405, "method not allowed", { Allow => "GET,HEAD,POST" });
 237             return;
 238          }
 239
 240          if ($vm >= 2) {
 241             $self->error (506, "http protocol version not supported");
 242             return;
 243          }
 244
 245          $hdr = _parse_headers ($h);
 246
 247          $self->{last_header} = [$m, $u, $hdr];
 248
 249          if (defined $hdr->{'Content-Length'}) {
 250             $self->{content_len} = $hdr->{'Content-Length'};
 251             $self->handle_data ($rbuf);
 252          } else {
 253             $self->handle_request (@{$self->{last_header}});
 254          }
 255       }
 256    }
 257 }
 258
 259 sub do_disconnect {
 260    my ($self, $err) = @_;
 261    delete $self->{hdl};
 262    $self->event ('disconnect', $err);
 263 }
 264
 265 1;