File Coverage

blib/lib/Dancer2/Plugin/REST.pm

Criterion	Covered	Total	%
statement	55	56	98.2
branch	7	10	70.0
condition	8	10	80.0
subroutine	19	19	100.0
pod	2	3	66.6
total	91	98	92.8

package Dancer2::Plugin::REST;
our $AUTHORITY = 'cpan:SUKRIA';
# ABSTRACT: A plugin for writing RESTful apps with Dancer2
$Dancer2::Plugin::REST::VERSION = '1.02';
use 5.12.0;  # for the sub attributes

use strict;
use warnings;

use Carp;

use Dancer2::Plugin;

use Dancer2::Core::HTTP 0.203000;
use List::Util qw/ pairmap pairgrep /;

my %content_types = (
    yaml => 'text/x-yaml',
    yml  => 'text/x-yaml',
    json => 'application/json',
    dump => 'text/x-data-dumper',
    ''   => 'text/html',
);

# TODO check if we use the handles
has '+app' => (
    handles => [qw/
        add_hook
        add_route
        response
        request
    /],
);

sub prepare_serializer_for_format :PluginKeyword {
    my $self = shift;

    my $conf = $self->app->config;
    if( my $serializer = $conf->{serializer} ) {
        warn "serializer '$serializer' specified in config file, overrode by Dancer2::Plugin::REST\n";
    }

    $conf->{serializer} = 'Mutable::REST';

    $self->add_hook( Dancer2::Core::Hook->new(
        name => 'before',
        code => sub {
            my $format = $self->request->params->{'format'}
                         || eval { $self->request->captures->{'format'} };

            my $content_type = lc $content_types{$format||''} or return;

            $self->request->headers->header( 'Content-Type' => $content_type );

        }
    ) );
}

sub resource :PluginKeyword {
    my ($self, $resource, %triggers) = @_;

    my %actions = (
        update => 'put',
        create => 'post',
        map { $_ => $_ } qw/ get delete /
    );

    croak "resource should be given with triggers"
      unless defined $resource
             and grep { $triggers{$_} } keys %actions;

    while( my( $action, $code ) = each %triggers ) {
            $self->add_route(
                method => $actions{$action},
                regexp => $_,
                code   => $code,
            ) for map { sprintf $_, '/:id' x ($action ne 'create') }
                        "/${resource}%s.:format", "/${resource}%s";
    }
};

sub send_entity :PluginKeyword {
    my ($self, $entity, $http_code) = @_;

    $self->response->status($http_code || 200);
    $entity;
};

sub _status_helpers {
    return
                # see https://github.com/PerlDancer/Dancer2/pull/1235
           pairmap { ( $a =~ /\d.*_/ ? (split '_', $a, 2 )[1] : $a ), $b  }
           pairmap  { $a =~ /^\d+$/ ? ( $a => $a ) : ( $a => $b ) }
           pairgrep { $a !~ /[A-Z]/ }
                    Dancer2::Core::HTTP->all_mappings;
}

plugin_keywords pairmap {
    { # inner scope because of the pairmap closure bug <:-P
        my( $helper_name, $code ) = ( $a, $b );
        $helper_name = "status_${helper_name}";

        $helper_name => sub {
            $_[0]->send_entity(
                ( ( $code >= 400 && ! ref $_[1] ) ? {error => $_[1]} : $_[1] ),
                $code
            );
        };
    }
} _status_helpers();

1;

package
    Dancer2::Serializer::Mutable::REST;

# TODO write patch for D2:S:M to provide our own mapping
# and then we'll be able to preserce the 'text/html'

use Moo;

extends 'Dancer2::Serializer::Mutable';

around _get_content_type => sub {
    my( $orig, $self, $entity ) = @_;

    $self->has_request or return;

    my $ct = $self->request->header( 'content_type' );

    if( $ct eq 'text/html' or $ct eq '' ) {
        $self->set_content_type( 'text/html' );
        return;
    }

    $orig->($self,$entity);
};

1;

__END__