File Coverage

blib/lib/Raisin/Middleware/Formatter.pm

Criterion	Covered	Total	%
statement	111	111	100.0
branch	34	36	94.4
condition	6	10	60.0
subroutine	19	19	100.0
pod	4	5	80.0
total	174	181	96.1

#!perl
#PODNAME: Raisin::Middleware::Formatter
#ABSTRACT: A parser/formatter middleware for L.

use strict;
use warnings;

package Raisin::Middleware::Formatter;
$Raisin::Middleware::Formatter::VERSION = '0.94';
use parent 'Plack::Middleware';

use File::Basename qw(fileparse);
use HTTP::Status qw(:constants);
use Scalar::Util qw{ blessed reftype openhandle };
use Plack::Request;
use Plack::Response;
use Plack::Util;
use Plack::Util::Accessor qw(
    default_format
    format
    encoder
    decoder
    raisin
);

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

    # Pre-process
    my $req = Plack::Request->new($env);

    if ($req->content) {
        my %media_types_map_flat_hash = $self->decoder->media_types_map_flat_hash;

        my ($ctype) = split /;/, $req->content_type, 2;
        my $format = $media_types_map_flat_hash{$ctype};
        unless ($format) {
            Raisin::log(info => "unsupported media type: ${ \$req->content_type }");
            return Plack::Response->new(HTTP_UNSUPPORTED_MEDIA_TYPE)->finalize;
        }
        $env->{'raisinx.decoder'} = $format;

        my $d = Plack::Util::load_class($self->decoder->for($format));
        $env->{'raisinx.body_params'} = $d->deserialize($req);
    }

    my $format = $self->negotiate_format($req);
    unless ($format) {
        return Plack::Response->new(HTTP_NOT_ACCEPTABLE)->finalize;
    }
    $env->{'raisinx.encoder'} = $format;

    my $res = $self->app->($env);
    # Post-process
    Plack::Util::response_cb($res, sub {

        my $res = shift;
        my $r = Plack::Response->new(@$res);

        # The application may decide on the fly to return a different
        # content type than we negotiated above. In that case it becomes
        # responsible for updating $env appropriately, and also
        # specifying the encoder to use.
        my $format = $env->{'raisinx.encoder'};

        # If the body is a data structure of some sort, finalize it now,
        # BUT NOT if it's a file handle (broadly construed). In that case
        # treat it as a deferred response.
        if (ref $r->body && !_is_a_handle($r->body)) {
            my $s = Plack::Util::load_class($self->encoder->for($format));

            $r->content_type($s->content_type) unless $r->content_type;
            $r->body($s->serialize($r->body));
        }

        @$res = @{ $r->finalize };
        return;
    });
}

# Test whether the argument is a "handle," meaning that it's either
# a built-in handle or an IO::Handle-like object.  It's a file handle
# if fileno or Scalar::Util::openhandle think it is, or if it supports
# a "getline" and a "close" method.
sub _is_a_handle {
    my ($var) = @_;

    return
        ( ( reftype $var // '' ) eq 'GLOB' && ( defined fileno($var) || defined openhandle($var) ) )
        ||
        ( blessed $var && $var->can('getline') && $var->can('close') )
        ;
}

sub _accept_header_set { length(shift || '') }
sub _path_has_extension {
    my $path = shift;
    my (undef, undef, $suffix) = fileparse($path, qr/\..[^.]*$/);
    $suffix;
}

sub negotiate_format {
    my ($self, $req) = @_;

    my @allowed_formats = $self->allowed_formats_for_requested_route($req);

    # PRECEDENCE:
    #   - known extension
    #   - headers
    #   - default
    my @wanted_formats = do {
        my $ext_format = $self->format_from_extension($req->path);
        if ($ext_format) {
            $ext_format;
        }
        elsif (_accept_header_set($req->header('Accept'))) {
            # In case of wildcard matches, we default to first allowed format
            $self->format_from_header($req->header('Accept'), $allowed_formats[0]);
        }
        else {
            $self->default_format;
        }
    };

    my @matching_formats = grep {
        my $format = $_;
        grep { $format && $format eq $_ } @allowed_formats
    } @wanted_formats;

    shift @matching_formats;
}

sub format_from_extension {
    my ($self, $path) = @_;
    return unless $path;

    my $ext = _path_has_extension($path);
    return unless $ext;

    # Trim leading dot in the extension.
    $ext = substr($ext, 1);

    my %media_types_map_flat_hash = $self->encoder->media_types_map_flat_hash;
    my $format = $media_types_map_flat_hash{$ext};
    return unless $format;

    $format;
}

sub format_from_header {
    my ($self, $accept, $assumed_wildcard_format) = @_;
    return unless $accept;

    my %media_types_map_flat_hash = $self->encoder->media_types_map_flat_hash;
    # Add a default format as a `*/*`
    $media_types_map_flat_hash{'*/*'} = $assumed_wildcard_format;

    my @media_types;
    for my $type (split /\s*,\s*/, $accept) {
        my ($media, $params) = split /;/, $type, 2;
        # Cleaning up media type by deleting a Vendor tree
        $media =~ s/vnd\.[^+]+\+//g;

        next unless my $format = $media_types_map_flat_hash{$media};

        my $q = ($params // '') =~ /q=([\d\.]+)/ ? $1 : 1;

        push @media_types, { format => $format, q => $q };
    }

    map { $_->{format} } sort { $b->{q} <=> $a->{q} } @media_types;
}

sub allowed_formats_for_requested_route {
    my ($self, $req) = @_;
    # Global format has been forced upon entire app
    return $self->format if $self->format;

    # Route specific `produces` restrictions
    if ( $self->raisin ) {
        my $route = $self->raisin->routes->find($req->method, $req->path);
        return @{$route->{produces}} if $route->{produces};
    }

    # Prefer Default, allow all others
    my @allowed = keys %{ $self->encoder->all };
    unshift @allowed, $self->default_format if $self->default_format;
    return @allowed;
}

1;

__END__