File Coverage

blib/lib/Dancer2/Plugin/ParamTypes.pm

Criterion	Covered	Total	%
statement	99	100	99.0
branch	33	42	78.5
condition	9	12	75.0
subroutine	15	15	100.0
pod	3	4	75.0
total	159	173	91.9

package Dancer2::Plugin::ParamTypes;
# ABSTRACT: Parameter type checking plugin for Dancer2
$Dancer2::Plugin::ParamTypes::VERSION = '0.004';
use strict;
use warnings;
use constant {
    'ARGS_NUM_BASIC'    => 3,
    'ARGS_NUM_OPTIONAL' => 4,
    'HTTP_BAD_REQUEST'  => 400,
};

use Carp ();
use Dancer2::Plugin;
use Scalar::Util ();
use Ref::Util qw< is_ref is_arrayref >;

plugin_keywords(qw);

has 'type_checks' => (
    'is'      => 'ro',
    'default' => sub { +{} },
);

has 'type_actions' => (
    'is'      => 'ro',
    'builder' => '_build_type_actions',
);

sub _build_type_actions {
    my $self = shift;
    Scalar::Util::weaken( my $plugin = $self );
    return {
        'error' => sub {
            my ( $self, $details ) = @_;
            my ( $type, $name )    = @{$details}{qw};

            $plugin->dsl->send_error(
                "Parameter $name must be $type",
                HTTP_BAD_REQUEST(),
            );
        },

        'missing' => sub {
            my ( $self, $details ) = @_;
            my ( $name, $type )    = @{$details}{qw};

            $self->dsl->send_error(
                "Missing parameter: $name ($type)",
                HTTP_BAD_REQUEST(),
            );
        },
    };
}

sub register_type_check {
    my ( $self, $name, $cb ) = @_;
    $self->type_checks->{$name} = $cb;
    return;
}

sub register_type_action {
    my ( $self, $name, $cb ) = @_;
    $self->type_actions->{$name} = $cb;
    return;
}

sub with_types {
    my ( $self, $full_type_details, $cb ) = @_;
    my %params_to_check;

    is_arrayref($full_type_details)
        or Carp::croak('Input for with_types must be arrayref');

    ## no critic qw(ControlStructures::ProhibitCStyleForLoops)
    for ( my $idx = 0; $idx <= $#{$full_type_details}; $idx++ ) {
        my $item = $full_type_details->[$idx];
        my ( $is_optional, $type_details )
            = is_arrayref($item)   ? ( 0, $item )
            : $item eq 'optional'  ? ( 1, $full_type_details->[ ++$idx ] )
            : Carp::croak("Unsupported type option: $item");

        my ( $sources, $name, $type, $action ) = @{$type_details};

        @{$type_details} == ARGS_NUM_BASIC() ||
        @{$type_details} == ARGS_NUM_OPTIONAL()
            or Carp::croak("Incorrect number of elements for type ($name)");

        # default action
        defined $action && length $action
            or $action = 'error';

        if ( is_ref($sources) ) {
            is_arrayref($sources)
                or Carp::croak("Source cannot be of @{[ ref $sources ]}");

            @{$sources} > 0
                or Carp::croak('You must provide at least one source');
        } else {
            $sources = [$sources];
        }

        foreach my $src ( @{$sources} ) {
            $src eq 'route' || $src eq 'query' || $src eq 'body'
                or Carp::croak("Type $name provided from unknown source '$src'");
        }

        defined $self->type_checks->{$type}
            or Carp::croak("Type $name provided unknown type '$type'");

        defined $self->type_actions->{$action}
            or
            Carp::croak("Type $name provided unknown action '$action'");

        defined $self->type_actions->{'missing'}
            or Carp::croak('You need to provide a "missing" action');

        my $src = join ':', sort @{$sources};
        $params_to_check{$src}{$name} = {
            'optional' => $is_optional,
            'source'   => $src,
            'name'     => $name,
            'type'     => $type,
            'action'   => $action,
        };
    }

    # Couldn't prove yet that this is required, but it makes sense to me
    Scalar::Util::weaken( my $plugin = $self );

    return sub {
        my @route_args = @_;

        # Hash::MultiValue has "each" method which we could use to
        # traverse it in the opposite direction (for each parameter sent
        # we find the appropriate value and check it), but that could
        # possibly introduce an attack vector of sending a lot of
        # parameters to force longer loops. For now, the loop is based
        # on how many parameters to added to be checked, which is a known
        # set. (GET has a max limit, PUT/POST...?) -- SX

        # Only check if anything was supplied
        foreach my $source ( keys %params_to_check ) {
            foreach my $name ( keys %{ $params_to_check{$source} } ) {
                my @sources = split /:/xms, $source;
                my $details = $params_to_check{$source}{$name};

                if ( @sources == 1 ) {
                    $plugin->run_check($details)
                        or
                        $self->type_actions->{'missing'}->( $self, $details );
                } else {
                    my $found;
                    foreach my $single_source (@sources) {
                        $details->{'source'} = $single_source;
                        if ( $plugin->run_check($details) ) {
                            $found++;
                            last;
                        }
                    }

                    $found
                        or
                        $self->type_actions->{'missing'}->( $self, $details );
                }
            }
        }

        $cb->(@route_args);
    };
}

sub run_check {
    my ( $self, $details ) = @_;

    my ( $source, $name, $type, $action, $optional )
        = @{$details}{qw};

    my $app     = $self->app;
    my $request = $app->request;

    my $params
        = $source eq 'route' ? $request->route_parameters
        : $source eq 'query' ? $request->query_parameters
        :                      $request->body_parameters;

    # No parameter value, is this okay or not?
    if ( !exists $params->{$name} ) {
        # It's okay, ignore
        $optional
            and return 1;

        # Not okay, missing when it's required!
        return;
    }

    my @param_values = $params->get_all($name);
    my $check_cb     = $self->type_checks->{$type};

    foreach my $param_value (@param_values) {
        if ( ! $check_cb->($param_value) ) {
            my $action_cb
                = $self->type_actions->{$action};

            return $action_cb->( $self, $details );
        }
    }

    return 1;
}

1;

__END__