File Coverage

blib/lib/Dancer/Plugin/Resource.pm

Criterion	Covered	Total	%
statement	111	126	88.1
branch	23	34	67.6
condition	24	35	68.5
subroutine	21	23	91.3
pod			n/a
total	179	218	82.1

#
# This file is part of Dancer-Plugin-Resource
#
# This software is copyright (c) 2013 by Matthew Phillips.
#
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
#
package Dancer::Plugin::Resource;
# ABSTRACT: A plugin for writing declarative RESTful apps with Dancer
BEGIN {
our $VERSION = '1.131120'; # VERSION
}

use strict;
use warnings;

use Carp 'croak';
use Dancer ':syntax';
use Dancer::Plugin;
use Lingua::EN::Inflect::Number;

our $RESOURCE_DEBUG = 0;

my $content_types = {
    json => 'application/json',
    yml  => 'text/x-yaml',
    xml  => 'application/xml',
};

my %routes;

# thanks leont
sub _function_exists {
    no strict 'refs';
    my $funcname = shift;
    return \&{$funcname} if defined &{$funcname};
    return;
}

sub prepare_serializer_for_format {
    my $conf        = plugin_setting;
    my $serializers = (
        ($conf && exists $conf->{serializers})
        ? $conf->{serializers}
        : { 'json' => 'JSON',
            'yml'  => 'YAML',
            'xml'  => 'XML',
            'dump' => 'Dumper',
        }
    );

    hook 'before' => sub {
        my $format = params->{'format'};
        if (not defined $format) {
            set serializer => 'Mutable';
            return;
        }

        return unless defined $format;

        my $serializer = $serializers->{$format};
        unless (defined $serializer) {
            return halt(
                Dancer::Error->new(
                    code    => 404,
                    message => "unsupported format requested: " . $format
                )
            );
        }

        set serializer => $serializer;
        my $ct = $content_types->{$format} || setting('content_type');
        content_type $ct;
    };
}
register prepare_serializer_for_format => \&prepare_serializer_for_format;

register resource => sub {
    my ($resource, %options) = @_;

    my $params = ':id';
    my ($old_prefix, $parent_prefix);

    unless ($options{skip_prepare_serializer} || ((caller)[1] =~ /^(?:t|xt)/)) {
        prepare_serializer_for_format;
    }

    # if this resource is a nested child resource, manage the prefix
    $old_prefix = Dancer::App->current->prefix || '';
    $parent_prefix = '';

    if ($options{parent} and $routes{$options{parent}}) {
        prefix $parent_prefix = $routes{$options{parent}};
    }
    else {
        $parent_prefix = $old_prefix;
    }

    # create a default for the load funcs
    $options{$_} ||= sub { undef } for (qw/load load_all/);

    # if member => 'foo' is passed, turn it into an array
    for my $type (qw/member collection/) {
        if ($options{$type} && ref $options{$type} eq '') {
            $options{$type} = [$options{$type}];
        }
    }

    # by default take the singular resource as the param name (ie :user for users)
    my ($singular_resource, $plural_resource) = (Lingua::EN::Inflect::Number::to_S($resource), $resource);

    # or if the user wants to override to take multiple params, ie /user/:foo/:bar/:baz
    # allow it. This could be useful for composite key schemas
    if ( my $p = $options{params} ) {
        $p = ref $p ? $p : [$p];
        $params = join '/', map ":${_}", @{$p};
    }
    else {
        $params = ":${singular_resource}_id";
    }

    my ($package) = caller;

    # main resource endpoints
    # CRUD
    _post(
        _endpoint(
            path     => $plural_resource,
            params   => '',
            verbs    => [qw/POST create/],
            function => $singular_resource
        )
    );

    _get(
        _endpoint(
            path     => $plural_resource,
            params   => $params,
            verbs    => [qw/GET get read/],
            loader   => $options{load},
            function => $singular_resource
        )
    );

    _put(
        _endpoint(
            path     => $plural_resource,
            params   => $params,
            verbs    => [qw/PUT update/],
            loader   => $options{load},
            function => $singular_resource
        )
    );

    _del(
        _endpoint(
            path     => $plural_resource,
            params   => $params,
            verbs    => [qw/DELETE delete/],
            loader   => $options{load},
            function => $singular_resource
        )
    );

    _get(
        _endpoint(
            path     => $plural_resource,
            params   => '',
            verbs    => [qw/INDEX index/],
            loader   => $options{load_all},
            function => $singular_resource
        )
    );

    # member routes are actions on the given id. ie /users/:user_id/foo
    for my $member (@{$options{member}}) {
        my $path = "${plural_resource}/$params/${member}";
        my $member_param = "";

        _post(
            _endpoint(
                path     => $path,
                params   => '',
                verbs    => [qw/POST create/],
                loader   => $options{load},
                function => "${singular_resource}_${member}"
            )
        );

        _get(
            _endpoint(
                path     => $path,
                params   => $member_param,
                verbs    => [qw/GET get read/],
                loader   => $options{load},
                function => "${singular_resource}_${member}"

            )
        );

        _put(
            _endpoint(
                path     => $path,
                params   => $member_param,
                verbs    => [qw/PUT update/],
                loader   => $options{load},
                function => "${singular_resource}_${member}"

            )
        );

        _del(
            _endpoint(
                path     => $path,
                params   => $member_param,
                verbs    => [qw/DELETE delete/],
                loader   => $options{load},
                function => "${singular_resource}_${member}"

            )
        );
    }

    # collection routes are actions on the collection. ie /users/foo
    for my $collection (@{$options{collection}}) {
        my $path = "${plural_resource}/${collection}";

        _post(
            _endpoint(
                path     => $path,
                params   => '',
                verbs    => [qw/POST create/],
                loader   => $options{load_all},
                function => "${plural_resource}_${collection}"
            )
        );

        _get(
            _endpoint(
                path     => $path,
                params   => '',
                verbs    => [qw/GET get read/],
                loader   => $options{load_all},
                function => "${plural_resource}_${collection}"
            )
        );

        _put(
            _endpoint(
                path     => $path,
                params   => '',
                verbs    => [qw/PUT update/],
                loader   => $options{load_all},
                function => "${plural_resource}_${collection}"
            )
        );

        _del(
            _endpoint(
                path     => $path,
                params   => '',
                verbs    => [qw/DELETE delete/],
                loader   => $options{load_all},
                function => "${plural_resource}_${collection}"
            )
        );
    }

    # save every defined resource if it is referred as a parent in a nested child resource
    $routes{$resource} = "${parent_prefix}/${plural_resource}/${params}";

    # restore existing prefix if saved
    prefix $old_prefix if $old_prefix;
};

sub _debug { $RESOURCE_DEBUG and print @_ }

sub _post {
    my ($route, $sub) = @_;
    for ($route . '.:format', $route) {
        _debug("=> POST " .(Dancer::App->current->prefix||'').$_."\n");
        post($_ => $sub);
    }
}

sub _get {
    my ($route, $sub) = @_;
    for ($route . '.:format', $route) {
        _debug("=> GET " .(Dancer::App->current->prefix||'').$_."\n");
        get($_ => $sub);
    }
}

sub _put {
    my ($route, $sub) = @_;
    for ($route . '.:format', $route) {
        _debug("=> PUT " .(Dancer::App->current->prefix||'').$_."\n");
        put($_ => $sub);
    }
}

sub _del {
    my ($route, $sub) = @_;
    for ($route . '.:format', $route) {
        _debug("=> DEL " .(Dancer::App->current->prefix||'').$_."\n");
        del($_ => $sub);
    }
}

sub _endpoint {
    my %opts = @_;
    my ($function, $word, $params, $verbs, $load_func) = @opts{qw/function path params verbs loader/};

    my $package = caller(1);

    my $wrapped;
    for my $verb (@$verbs) {
        # allow both foo_GET and GET_foo
        my $func = _function_exists("${package}::${verb}_${function}") ||
                   _function_exists("${package}::${function}_${verb}");

        if ($func) {
            _debug("${package}::${verb}_${function} ");
            $wrapped = sub { $func->($load_func ? $load_func->() : (), @_) };

            last; # we only want to attach to the first successful verb
        }
    }

    if (not $wrapped) {
        _debug("undef ");

        # if we've gotten this far, no route exists. use a default
        $wrapped = sub { status_method_not_allowed('Method not allowed.'); };
    }

    my $route
        = $params ? "/${word}/${params}"
        :           "/${word}";

    return ($route, $wrapped);
}

register send_entity => sub {
    my ($entity, $http_code) = @_;

    $http_code ||= 200;

    status($http_code);
    $entity;
};

my %http_codes = (

    # 1xx
    100 => 'Continue',
    101 => 'Switching Protocols',
    102 => 'Processing',

    # 2xx
    200 => 'OK',
    201 => 'Created',
    202 => 'Accepted',
    203 => 'Non-Authoritative Information',
    204 => 'No Content',
    205 => 'Reset Content',
    206 => 'Partial Content',
    207 => 'Multi-Status',
    210 => 'Content Different',

    # 3xx
    300 => 'Multiple Choices',
    301 => 'Moved Permanently',
    302 => 'Found',
    303 => 'See Other',
    304 => 'Not Modified',
    305 => 'Use Proxy',
    307 => 'Temporary Redirect',
    310 => 'Too many Redirect',

    # 4xx
    400 => 'Bad Request',
    401 => 'Unauthorized',
    402 => 'Payment Required',
    403 => 'Forbidden',
    404 => 'Not Found',
    405 => 'Method Not Allowed',
    406 => 'Not Acceptable',
    407 => 'Proxy Authentication Required',
    408 => 'Request Time-out',
    409 => 'Conflict',
    410 => 'Gone',
    411 => 'Length Required',
    412 => 'Precondition Failed',
    413 => 'Request Entity Too Large',
    414 => 'Request-URI Too Long',
    415 => 'Unsupported Media Type',
    416 => 'Requested range unsatisfiable',
    417 => 'Expectation failed',
    418 => 'Teapot',
    422 => 'Unprocessable entity',
    423 => 'Locked',
    424 => 'Method failure',
    425 => 'Unordered Collection',
    426 => 'Upgrade Required',
    449 => 'Retry With',
    450 => 'Parental Controls',

    # 5xx
    500 => 'Internal Server Error',
    501 => 'Not Implemented',
    502 => 'Bad Gateway',
    503 => 'Service Unavailable',
    504 => 'Gateway Time-out',
    505 => 'HTTP Version not supported',
    507 => 'Insufficient storage',
    509 => 'Bandwidth Limit Exceeded',
);

for my $code (keys %http_codes) {
    my $helper_name = lc($http_codes{$code});
    $helper_name =~ s/[^\w]+/_/gms;
    $helper_name = "status_${helper_name}";

    register $helper_name => sub {
        if ($code >= 400 && ref $_[0] eq '') {
            send_entity({error => $_[0]}, $code);
        }
        else {
            send_entity($_[0], $code);
        }
    };
}

register_plugin;
1;


__END__