インメモリ簡易版 multipart/form-data デコーダ

Lamawiki で使っている、簡易版のマルチパート・デコーダでは、Content-Type ヘッダからバウンダリをとりだす部分を手抜きしすぎていたので、手直ししました。手抜きといっても、CPANCGI モジュール、HTTP モジュールも手抜き具合は同様で、それで問題がおきたという報告を探しても見当たらないので、気にすることはないのかもしれませんけど。

さて、RFC 7230 / RFC 7231 の規格では、バウンダリはメディア・タイプのパラメータの一つとしてヘッダに書き込まれることになっています。パラメータの書式は 2 種類あって、 token と quoted-string の生成規則になっています。前者は単純な文字の羅列で、後者はエスケープ文字ありでやや複雑です。

https://tools.ietf.org/html/rfc7231 の ABNF を PEG に変換

    media-type    <- token '/' token ([ \t]* ';' [ \t]* parameter)
    parameter     <- token '=' (token / quoted-string)

https://tools.ietf.org/html/rfc7230 の ABNF を PEG に変換

    token         <- [!#$%&'*+\-.^_`|~0-9A-Za-z]+
    quoted-string <- '"' (qdtext / quoted-pair) '"'
    qdtext        <- [\t \x21\x23-\x5b\x5d-\x7e]   # obs-text <- [\x80-\xff] を除いた
    quoted-pair   <- '\\' [\t \x21-\x7e]

ただし、ログを見ている限りでは、バウンダリは現行のメジャーなブラウザはすべて token で生成し、quoted-string が送られてくることはめったにありません。quoted-string がたまに送られてきても、エスケープ文字を含んだものは、今のところ見たことがありません。Content-Disposition: form-data ヘッダの名前とファイル名は quoted-string になっている場合が多いのですが、MSIE が送ったファイル名ではバックスラッシュをエスケープせずにそのまま送ってくるので、真面目に quoted-string として扱うとパスの区切り文字が消えてしまいます。

余談ながら、HTTP/1.1 と電子メールのヘッダの書式には一点大きな相違点があって、電子メールのヘッダの値フィールドにはどこにでも丸括弧で囲んだコメントを置くことが許されています。このコメントがやっかいで、入れ子にできる上にエスケープもできるので、素の正規表現では扱い辛いものです。一方、HTTP/1.1 では、規格で許した箇所だけにコメントが出現できます。Content-Type ヘッダにはコメントが許されていないので、電子メールのヘッダの解釈をおこなう場合に比べて、単純な正規表現でヘッダを扱えます。

手直し版では、 token か quoted-string に規格で許されている文字だけを受け付けるようにしています。 ただし、複数行に渡っているヘッダの CRLF をチェックの前に削るため、quoted-string の途中で改行している場合の検出ができなくなっています。

sub body_parameters {
    my($env, $param, $maxpost) = @_;
    my $fb = Encode::FB_CROAK|Encode::LEAVE_SRC;
    my $ctype = $env->{'CONTENT_TYPE'} || q();
    $ctype =~ s/\x0d\x0a[ \t]+/ /gmsx;
    my %ct;
    if ($ctype =~ m{\A[ \t]*(?i:multipart/form-data)([^\n]*)}msx) {
        %ct = content_header_parameters ($1);
    }
    my $bnd = exists $ct{'boundary'} ? $ct{'boundary'} : return +{};
    my $length = $env->{'CONTENT_LENGTH'} or return +{};
    $length <= $maxpost or return +{};
    read $env->{'psgi.input'}, my($s), $length or return +{};
    $s =~ m/\G--$bnd\x0d\x0a/gcmsx or return +{};
    my $part = qr/\G(.*?\x0d\x0a)\x0d\x0a(.*?)\x0d\x0a--$bnd(--)?\x0d\x0a/msx;
    while ($s =~ m/$part/gcmsx) {
        my($h, $v, $e) = ($1, $2, $3);
        $h =~ s/\x0d\x0a([ \t]+)/$1 ? q( ) : "\n"/gmsx;
        my %cd;
        if ($h =~ m{^(?i:content-disposition):[ ~\t]*(?i:form-data)([^\n]*)}msx) {
            %cd = content_header_parameters ($1);
        }
        return +{} if exists $cd{'filename'};
        my $k = exists $cd{'name'} ? $cd{'name'} : return +{};
        $v =~ s/\x0d\x0a/\n/gmsx;
        eval{ $v = decode('UTF-8', $v, $fb); 1; } or return +{};
        $param->{$k} = $v;
        last if $e;
    }
    return $param;
}

# see RFC 7230 3.2.6. token and quoted-string
my $token = qr{[!\#\$%&\'*+\-.^_`\|~0-9A-Za-z]+}msx;
my $qstr = qr{[\t \x21\x23-\x5b\x5d-\x7e]*
     (?:\\[\t\x20-\x7e][\t \x21\x23-\x5b\x5d-\x7e]*)*}msx;

sub content_header_parameters {
    my($t) = @_;
    my %h;
    while ($t =~ m{\G[ \t]*;[ \t]*($token)=(?:($token)|"($qstr)")}gcmsx) {
        my($k, $v) = ($1, $+);
        if (defined $3) {
            $v =~ s/\\(.)/$1/gmsx;
        }
        $h{lc $k} = $v;
    }
    return %h if $t =~ m{\G\s*\z}gcmsx;
    return ();
}