Flexible request body parser

benchmarks/body-parser.pl

@@ -0,0 +1,66 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use utf8;
+use 5.010000;
+use autodie;
+
+use Plack::Request;
+use Plack::BodyParser::UrlEncoded;
+use Plack::BodyParser::JSON;
+use Plack::BodyParser::MultiPart;
+use Plack::BodyParser::OctetStream;
+
+use Benchmark ':all';
+
+my $content = 'xxx=hogehoge&yyy=aaaaaaaaaaaaaaaaaaaaa';
+
+my $body_parser = sub {
+    open my $input, '<', \$content;
+    my $req = Plack::Request->new(
+        +{
+            'psgi.input' => $input,
+            CONTENT_LENGTH => length($content),
+            CONTENT_TYPE => 'application/x-www-form-urlencoded',
+        },
+        parse_request_body => \&parse_request_body,
+    );
+    $req->body_parameters;
+};
+my $orig = sub {
+    open my $input, '<', \$content;
+    my $req = Plack::Request->new(
+        +{
+            'psgi.input' => $input,
+            CONTENT_LENGTH => length($content),
+            CONTENT_TYPE => 'application/x-www-form-urlencoded',
+        },
+    );
+    $req->body_parameters;
+};
+use Data::Dumper; warn Dumper($orig->());
+use Data::Dumper; warn Dumper($body_parser->());
+
+cmpthese(
+    -1, {
+        orig => $orig,
+        body_parser => $body_parser,
+    },
+);
+
+sub parse_request_body {
+    my $req = shift;
+    my $content_type = $req->content_type;
+
+    my $parser =
+        $content_type =~ m{\Aapplication/json}
+            ? Plack::BodyParser::JSON->new()
+        : $content_type =~ m{\Aapplication/x-www-form-urlencoded}
+            ? Plack::BodyParser::UrlEncoded->new()
+        : $content_type =~ m{\Amultipart/form-data}
+            ? Plack::BodyParser::MultiPart->new($req->env)
+            : Plack::BodyParser::OctetStream->new()
+    ;
+    Plack::BodyParser->parse($req->env, $parser);
+}
+

cpanfile

@@ -4,7 +4,6 @@ requires 'Devel::StackTrace', '1.23';
 requires 'Devel::StackTrace::AsHTML', '0.11';
 requires 'File::ShareDir', '1.00';
 requires 'Filesys::Notify::Simple';
-requires 'HTTP::Body', '1.06';
 requires 'HTTP::Message', '5.814';
 requires 'Hash::MultiValue', '0.05';
 requires 'Pod::Usage', '1.36';
@@ -15,6 +14,9 @@ requires 'URI', '1.59';
 requires 'parent';
 requires 'Apache::LogFormat::Compiler', '0.12';
 requires 'HTTP::Tiny', 0.034;
+requires 'URL::Encode';
+requires 'HTTP::MultiPartParser';
+requires 'JSON', 2;
 
 on test => sub {
     requires 'Test::More', '0.88';

lib/Plack/BodyParser.pm

@@ -0,0 +1,91 @@
+package Plack::BodyParser;
+use strict;
+use warnings;
+use utf8;
+use 5.008_001;
+use Hash::MultiValue;
+use Stream::Buffered;
+
+use Plack::BodyParser::OctetStream;
+
+sub new {
+    my $class = shift;
+    bless { handlers => [] }, $class;
+}
+
+sub register {
+    my ($self, $content_type, $klass, $opts) = @_;
+    push @{$self->{handlers}}, [$content_type, $klass, $opts];
+}
+
+sub get_parser {
+    my ($self, $env) = @_;
+
+    if (defined $env->{CONTENT_TYPE}) {
+        for my $handler (@{$self->{handlers}}) {
+            if (index($env->{CONTENT_TYPE}, $handler->[0]) == 0) {
+                return $handler->[1]->new($env, $handler->[2]);
+            }
+        }
+    }
+    return Plack::BodyParser::OctetStream->new();
+}
+
+sub parse {
+    my ($self, $env) = @_;
+
+    my $parser = $self->get_parser($env);
+
+    my $ct = $env->{CONTENT_TYPE};
+    my $cl = $env->{CONTENT_LENGTH};
+    if (!$ct && !$cl) {
+        # No Content-Type nor Content-Length -> GET/HEAD
+        $env->{'plack.request.body'}   = Hash::MultiValue->new;
+        $env->{'plack.request.upload'} = Hash::MultiValue->new;
+        return;
+    }
+
+    my $input = $env->{'psgi.input'};
+
+    my $buffer;
+    if ($env->{'psgix.input.buffered'}) {
+        # Just in case if input is read by middleware/apps beforehand
+        $input->seek(0, 0);
+    } else {
+        $buffer = Stream::Buffered->new($cl);
+    }
+
+    my $spin = 0;
+    while ($cl) {
+        $input->read(my $chunk, $cl < 8192 ? $cl : 8192);
+        my $read = length $chunk;
+        $cl -= $read;
+        $parser->add($chunk);
+        $buffer->print($chunk) if $buffer;
+
+        if ($read == 0 && $spin++ > 2000) {
+            Carp::croak "Bad Content-Length: maybe client disconnect? ($cl bytes remaining)";
+        }
+    }
+
+    if ($buffer) {
+        $env->{'psgix.input.buffered'} = 1;
+        $env->{'psgi.input'} = $buffer->rewind;
+    } else {
+        $input->seek(0, 0);
+    }
+
+    ($env->{'plack.request.body'}, $env->{'plack.request.upload'})
+        = $parser->finalize();
+
+    return 1;
+}
+
+
+1;
+__END__
+
+=head1 NAME
+
+Plack::BodyParser - HTTP request body parser
+

lib/Plack/BodyParser/JSON.pm

@@ -0,0 +1,40 @@
+package Plack::BodyParser::JSON;
+use strict;
+use warnings;
+use utf8;
+use 5.010_001;
+use JSON ();
+use Encode qw(encode_utf8);
+use Hash::MultiValue;
+
+sub new {
+    my $class = shift;
+    bless {buffer => ''}, $class;
+}
+
+sub add {
+    my $self = shift;
+    $self->{buffer} .= $_[0] if defined $_[0];
+}
+
+sub finalize {
+    my $self = shift;
+
+    my $p = JSON::decode_json($self->{buffer});
+    my $params = Hash::MultiValue->new();
+    if (ref $p eq 'HASH') {
+        while (my ($k, $v) = each %$p) {
+            if (ref $v eq 'ARRAY') {
+                for (@$v) {
+                    $params->add(encode_utf8($k), encode_utf8($_));
+                }
+            } else {
+                $params->add(encode_utf8($k), encode_utf8($v));
+            }
+        }
+    }
+    return ($params, Hash::MultiValue->new());
+}
+
+1;
+

lib/Plack/BodyParser/MultiPart.pm

@@ -0,0 +1,133 @@
+package Plack::BodyParser::MultiPart;
+use strict;
+use warnings;
+use utf8;
+use 5.010_001;
+use HTTP::MultiPartParser;
+use HTTP::Headers::Util    qw[split_header_words];
+use File::Temp;
+use Hash::MultiValue;
+use Carp ();
+use Plack::Request::Upload;
+use HTTP::Headers;
+
+sub new {
+    my ($class, $env, $opts) = @_;
+
+    my $self = bless { }, $class;
+
+    my $uploads = Hash::MultiValue->new();
+    my $params  = Hash::MultiValue->new();
+
+    unless (defined $env->{CONTENT_TYPE}) {
+        Carp::croak("Missing CONTENT_TYPE in PSGI env");
+    }
+    unless ( $env->{CONTENT_TYPE} =~ /boundary=\"?([^\";]+)\"?/ ) {
+        Carp::croak("Invalid boundary in content_type: $env->{CONTENT_TYPE}");
+    }
+    my $boundary = $1;
+
+    my $part;
+    my $parser = HTTP::MultiPartParser->new(
+        boundary => $boundary,
+        on_header => sub {
+            my ($headers) = @_;
+
+            my $disposition;
+            foreach (@$headers) {
+                if (/\A Content-Disposition: [\x09\x20]* (.*)/xi) {
+                    $disposition = $1;
+                    last;
+                }
+            }
+
+            (defined $disposition)
+                or die q/Content-Disposition header is missing in part/;
+
+            my ($p) = split_header_words($disposition);
+
+            ($p->[0] eq 'form-data')
+            or die q/Disposition type is not form-data/;
+
+            my ($name, $filename);
+            for(my $i = 2; $i < @$p; $i += 2) {
+                if    ($p->[$i] eq 'name')     { $name     = $p->[$i + 1] }
+                elsif ($p->[$i] eq 'filename') { $filename = $p->[$i + 1] }
+            }
+
+            (defined $name)
+                or die q/Parameter 'name' is missing from Content-Disposition header/;
+
+            $part = {
+                name    => $name,
+                headers => $headers,
+            };
+
+            if (defined $filename) {
+                $part->{filename} = $filename;
+
+                if (length $filename) {
+                    my $fh = File::Temp->new(UNLINK => 1);
+                    $part->{fh}       = $fh;
+                    $part->{tempname} = $fh->filename;
+
+                    # Save temporary files to $env.
+                    # Temporary files will remove after the request.
+                    push @{$env->{'plack.bodyparser.multipart.filehandles'}}, $part->{fh};
+                }
+            }
+        },
+        on_body => sub {
+            my ($chunk, $final) = @_;
+
+            my $fh = $part->{fh};
+
+            if ($fh) {
+                print $fh $chunk
+                    or die qq/Could not write to file handle: '$!'/;
+                if ($final) {
+                    seek($fh, 0, SEEK_SET)
+                        or die qq/Could not rewind file handle: '$!'/;
+
+                    my $headers = HTTP::Headers->new(
+                        map { split(/\s*:\s*/, $_, 2) }
+                        @{$part->{headers}}
+                    );
+                    $uploads->add($part->{name}, Plack::Request::Upload->new(
+                        headers  => $headers,
+                        size     => -s $part->{fh},
+                        filename => $part->{filename},
+                        tempname => $part->{tempname},
+                    ));
+                }
+            } else {
+                $part->{data} .= $chunk;
+                if ($final) {
+                    $params->add($part->{name}, $part->{data});
+                }
+            }
+        },
+        $opts->{on_error} ? (on_error => $opts->{on_error}) : (),
+    );
+
+    $self->{parser}  = $parser;
+    $self->{params}  = $params;
+    $self->{uploads} = $uploads;
+
+    return $self;
+}
+
+sub add {
+    my $self = shift;
+    $self->{parser}->parse($_[0]) if defined $_[0];
+}
+
+sub finalize {
+    my $self = shift;
+    $self->{parser}->finish();
+
+    return ($self->{params}, $self->{uploads});
+}
+
+1;
+

lib/Plack/BodyParser/OctetStream.pm

@@ -0,0 +1,22 @@
+package Plack::BodyParser::OctetStream;
+use strict;
+use warnings;
+use utf8;
+use 5.008_001;
+
+sub new {
+    my $class = shift;
+    bless {}, $class;
+}
+
+sub add { }
+
+sub finalize {
+    return (
+        Hash::MultiValue->new(),
+        Hash::MultiValue->new()
+    );
+}
+
+1;
+