File Coverage

blib/lib/Plack/Middleware/Negotiate.pm

Criterion	Covered	Total	%
statement	92	95	96.8
branch	28	34	82.3
condition	32	50	64.0
subroutine	17	20	85.0
pod	7	7	100.0
total	176	206	85.4

package Plack::Middleware::Negotiate;
#ABSTRACT: Apply HTTP content negotiation as Plack middleware
our $VERSION = '0.10'; #VERSION

use strict;
use v5.10.1;
use parent 'Plack::Middleware';

use Plack::Util::Accessor qw(formats parameter extension explicit);
use Plack::Request;
use HTTP::Negotiate qw(choose);
use Carp qw(croak);

use Log::Contextual::Easy::Default;

sub prepare_app {
    my $self = shift;

    croak __PACKAGE__ . ' requires formats'
        unless $self->formats and %{$self->formats};

    $self->formats->{_} //= { };

    unless ($self->formats->{_}->{type}) {
        foreach (grep { $_ ne '_' } keys %{$self->formats}) {
            croak __PACKAGE__ . " format requires type: $_"
                unless $self->formats->{$_}->{type};
        }
    }

    if (!$self->app) {
        $self->app( sub {
            [ 406, ['Content-Type'=>'text/plain'], ['Not Acceptable']];
        } );
    }
}

sub call {
    my ($self, $env) = @_;

    my $orig_path = $env->{PATH_INFO};

    my $format = $self->negotiate($env);
    $env->{'negotiate.format'} = $format;

    my $app;
    if ( $format and $format ne '_' and $self->formats->{$format} ) {
        $app = $self->formats->{$format}->{app};
    }
    $app //= $self->app;

    Plack::Util::response_cb( $app->($env), sub {
        my $res = shift;
        $self->add_headers( $res->[1], $env->{'negotiate.format'} );
        $env->{PATH_INFO} = $orig_path;
        $res;
    });
}

sub add_headers { # TODO: use Plack::Util or P:M:Headers
    my ($self, $headers, $name) = @_;

    my $format = $self->about($name) || return;
    my $fields = { @$headers };

    if (!$fields->{'Content-Type'}) {
        my $type = $format->{type};
        $type .= "; charset=". $format->{charset}
            if $format->{charset};
        push @$headers, 'Content-Type' => $type;
    }

    push @$headers, 'Content-Language' => $format->{language}
        if $format->{language} and !$fields->{'Content-Language'};
}

sub negotiate {
    my ($self, $env) = @_;
    my $req = Plack::Request->new($env);

    if (defined $self->parameter) {
        my $param = $self->parameter;

        my $format = $env->{QUERY_STRING} =~ /(^|&)$param=([^&]+)/ ? $2 : undef;

        if (!$self->known($format)) { # no GET parameter or unknown format
            $format = $req->body_parameters->{$param};
        }

        if ($self->known($format)) {
            log_trace { "format $format chosen based on query parameter" };
            unless ( $env->{QUERY_STRING} =~ s/&$param=([^&]+)//) {
                $env->{QUERY_STRING} =~ s/^$param=([^&]+)&?//;
            }
            return $format;
        }
    }

    if ($self->extension and $req->path =~ /\.([^.]+)$/ and $self->formats->{$1}) {
        my $format = $1;
        $env->{PATH_INFO} =~ s/\.$format$//
            if $self->extension eq 'strip';
        log_trace { "format $format chosen based on extension" };
        return $format;
    }

    if (!$self->explicit) {
        my $format = choose($self->variants, $req->headers);
        log_trace { "format $format chosen based on HTTP content negotiation" };
        return $format;
    }
}

sub about {
    my ($self, $name) = @_;

    return unless defined $name and $name ne '_';

    my $default = $self->formats->{_};
    my $format  = $self->formats->{$name} || return;

    return {
        quality  => $format->{quality} // $default->{quality} // 1,
        type     => $format->{type} // $default->{type},
        encoding => $format->{encoding} // $default->{encoding},
        charset  => $format->{charset} // $default->{charset},
        language => $format->{language} // $default->{language},
    };
}

sub known {
    my ($self, $name) = @_;
    return (defined $name and $name ne '_' and exists $self->formats->{$name});
}

sub variants {
    my $self = shift;
    return [
        sort { $a->[0] cmp $b->[0] }
        map {
            my $format = $self->about($_);
            [
                $_,
                $format->{quality},
                $format->{type},
                $format->{encoding},
                $format->{charset},
                $format->{language},
                0
        ] }
        grep { $_ ne '_' } keys %{$self->formats}
    ];
}

1;


__END__