File Coverage

blib/lib/Dancer2/Plugin/REST.pm

Criterion	Covered	Total	%
statement	56	56	100.0
branch	12	14	85.7
condition	9	14	64.2
subroutine	18	18	100.0
pod	2	3	66.6
total	97	105	92.3

package Dancer2::Plugin::REST;
our $AUTHORITY = 'cpan:SUKRIA';
# ABSTRACT: A plugin for writing RESTful apps with Dancer2
$Dancer2::Plugin::REST::VERSION = '1.01';
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 /;

# [todo] - add XML support
my $content_types = {
    json => 'application/json',
    yml  => 'text/x-yaml',
};

has '+app' => (
    handles => [qw/
        add_hook
        add_route
        setting
        response
        request
        send_error
        set_response
    /],
);

sub prepare_serializer_for_format :PluginKeyword {
    my $self = shift;

    my $conf        = $self->config;
    my $serializers = (
        ($conf && exists $conf->{serializers})
        ? $conf->{serializers}
        : { 'json' => 'JSON',
            'yml'  => 'YAML',
            'dump' => 'Dumper',
        }
    );

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

            return delete $self->response->{serializer}
                unless defined $format;

            my $serializer = $serializers->{$format}
                or return $self->send_error("unsupported format requested: " . $format, 404);

            $self->setting(serializer => $serializer);

            $self->set_response( Dancer2::Core::Response->new(
                %{ $self->response },
                serializer => $self->setting('serializer'),
            ) );

            $self->response->content_type(
                $content_types->{$format} || $self->setting('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;

__END__