package Dancer::Plugin::CRUD;

use Modern::Perl;

=head1 NAME

Dancer::Plugin::CRUD - A plugin for writing RESTful apps with Dancer

=head1 VERSION

Version 1.03

=cut

our $VERSION = '1.03';

=head1 DESCRIPTION

This plugin is derived from L<Dancer::Plugin::REST|Dancer::Plugin::REST> and helps you write a RESTful webservice with Dancer.

=head1 SYNOPSYS

	package MyWebService;
	
	use Dancer;
	use Dancer::Plugin::CRUD;
	
	prepare_serializer_for_format;
	
	my $userdb = My::UserDB->new(...);
	
	resource('user',
		'read' => sub { $userdb->find(captures()->{'user_id'}) }
	);
	
	# curl http://mywebservice/user/42.json
	{ "id": 42, "name": "John Foo", email: "john.foo@example.com"}
	
	# curl http://mywebservice/user/42.yml
	--
	id: 42
	name: "John Foo"
	email: "john.foo@example.com"

=cut

use Carp 'croak';
use Dancer ':syntax';
use Dancer::Plugin;
use Sub::Name;
use Text::Pluralize;
use Validate::Tiny ();

our $SUFFIX = '_id';

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

my %triggers_map = (
	get     => \&get,
	index   => \&get,
	read    => \&get,
	
	post    => \&post,
	create  => \&post,
	
	put     => \&put,
	update  => \&put,
	
	del     => \&del,
	delete  => \&del,
	
	patch   => \&patch,
);

my %alt_syntax = (
	get     => 'read',
	post    => 'create',
	put     => 'update',
	del     => 'delete',
);

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',
);

our $default_serializer;
my $stack = [];

sub _generate_sub($) {
	my %options = %{ shift() };
	
	my $resname = $options{stack}->[-1]->{resname};

	my $rules = [ map { $_->{validation_rules}->{generic} } grep { exists $_->{validation_rules} } reverse @{ $options{stack} } ];
	
	if (@$rules > 0) {
		push @$rules, $options{stack}->[-1]->{validation_rules}->{$options{action}}
			if exists $options{stack}->[-1]->{validation_rules}->{$options{action}};
			
		$rules = {
			fields  => [ map { ( @{ $_->{fields}  } ) } grep { exists $_->{fields}  } @$rules ],
			checks  => [ map { ( @{ $_->{checks}  } ) } grep { exists $_->{checks}  } @$rules ],
			filters => [ map { ( @{ $_->{filters} } ) } grep { exists $_->{filters} } @$rules ],
		};
	} else {
		$rules = undef;
	}
	
	my $chain = [ map { $_->{chain} } grep { exists $_->{chain} } @{ $options{stack} } ];
	
	my @idfields = map { $_->{resname}.$SUFFIX }
	               grep { (($options{action} =~ m'^(index|create)$') and ($_->{resname} eq $resname)) ? 0 : 1 }
				   @{ $options{stack} };
	
	my $subname = join('_', $resname, $options{action});
	
	return subname($subname, sub {
		if (defined $rules) {
			my $input = {
				%{ params('query') },
				%{ params('body') },
				%{ captures() || {} }
			};
			my $result = Validate::Tiny->new($input, {
				%$rules,
				fields => [
					@idfields,
					@{ $rules->{fields} }
				]
			});
			unless ($result->success) {
				status(400);
				return { error => $result->error };
			}
			var validate => $result;
		}
		
		{
			my @chain = @$chain;
			unless ($options{action} ~~ [qw[ read update delete patch ]]) {
				pop @chain;
			}
			$_->() for @chain;
		}
		
		my @ret = $options{coderef}->(map { $_->{resname} } @{ $options{stack} });
		
		if (@ret and defined $ret[0] and ref $ret[0] eq '' and $ret[0] =~ m{^\d{3}$}) {
			# return ($http_status_code, ...)
			if ($ret[0] >= 400) {
				# return ($http_error_code, $error_message)
				status($ret[0]);
				return { error => $ret[1] };
			} else {
				# return ($http_success_code, $payload)
				status($ret[0]);
				return $ret[1];
			}
		} elsif (status eq '200') {
			# http status wasn't changed yet
			given ($options{action}) {
				when ('create') { status(201); }
				when ('update') { status(202); }
				when ('delete') { status(202); }
			}
		}
		# return payload
		return (wantarray ? @ret : $ret[0]);
	});
}

sub _prefix {
    my ($prefix, $cb) = @_;
	
	my $app = Dancer::App->current;

    my $app_prefix = defined $app->app_prefix ? $app->app_prefix : "";
    my $previous = Dancer::App->current->prefix;

    if ($app->on_lexical_prefix) {
		if (ref $previous eq 'Regexp') {
	        $app->prefix(qr/${previous}${prefix}/);
		} else {
			my $previous_ = quotemeta($previous);
	        $app->prefix(qr/${previous_}${prefix}/);
		}
    } else {
		if (ref $app_prefix eq 'Regexp') {
	        $app->prefix(qr/${app_prefix}${prefix}/);
		} else {
			my $app_prefix_ = quotemeta($app_prefix);
	        $app->prefix(qr/${app_prefix_}${prefix}/);
		}
    }
	
    if (ref($cb) eq 'CODE') {
        $app->incr_lexical_prefix;
        eval { $cb->() };
        my $e = $@;
        $app->dec_lexical_prefix;
        $app->prefix($previous);
        die $e if $e;
    }
}



=head1 METHODS

=head2 C<< prepare_serializer_for_format >>

When this pragma is used, a before filter is set by the plugin to automatically
change the serializer when a format is detected in the URI.

That means that each route you define with a B<:format> token will trigger a
serializer definition, if the format is known.

This lets you define all the REST actions you like as regular Dancer route
handlers, without explicitly handling the outgoing data format.

=cut

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

    hook(before => sub {
        # remember what was there before
        $default_serializer ||= setting('serializer');

        my $format = defined captures() ? captures->{format} : undef;
		$format ||= param('format') or return;

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

        set(serializer => $serializer);

        # check if we were supposed to deserialize the request
        Dancer::Serializer->process_request(Dancer::SharedData->request);

        content_type($content_types->{$format} || setting('content_type'));
    });

    hook(after => sub {
        # put it back the way it was
        set(serializer => $default_serializer);
    });
};

=head2 C<< resource >>

This keyword lets you declare a resource your application will handle.

Derived from L<Dancer::Plugin::REST|Dancer::Plugin::REST>, this method has rewritten to provide a more slightly convention. C<get> has been renamed to C<read> and three new actions has been added: C<index>, C<patch>, C<prefix> and C<prefix_id>

Also, L<Text::Pluralize|Text::Pluralize> is applied to resource name with count=1 for singular variant and count=2 for plural variant. If you don't provide a singular/plural variant (i.e. resource name contains parenthesis) the singular and the plural becomes same.

The id name is derived from singular resource name, appended with C<_id>.

    resource 'user(s)' =>
        index  => sub { ... }, # return all users
        read   => sub { ... }, # return user where id = captures->{user_id}
        create => sub { ... }, # create a new user with params->{user}
        delete => sub { ... }, # delete user where id = captures->{user_id}
        update => sub { ... }, # update user with params->{user}
        patch  => sub { ... }, # patches user with params->{user}
        prefix => sub {
          # prefixed resource in plural
		  # routes are only possible with regex!
          get qr{/foo} => sub { ... },
        },
        prefix_id => sub {
          # prefixed resource in singular with id
		  # captures->{user_id}
		  # routes are only possible with regex!
          get qr{/bar} => sub { ... },
        };

    # this defines the following routes:
    # prefix_id =>
    #   GET /user/:user_id/bar
    # prefix =>
    #   GET /users/foo
    # index =>
    #   GET /users.:format
    #   GET /users
    # create =>
    #   POST /user.:format
    #   POST /user
    # read =>
    #   GET /user/:id.:format
    #   GET /user/:id
    # delete =>
    #   DELETE /user/:id.:format
    #   DELETE /user/:id
    # update =>
    #   PUT /user/:id.:format
    #   PUT /user/:id
    # patch =>
    #   PATCH /user.:format
    #   PATCH /user

The routes are created in the above order.

Returns a hash with arrayrefs of all created L<Dancer::Route|Dancer::Route> objects.
	
Hint: resources can be stacked with C<prefix>/C<prefix_id>:

	resource foo =>
		prefix => sub {
			get '/bar' => sub {
				return 'Hi!'
			};
		}, # GET /foo/bar
		prefix_id => sub {
			get '/bar' => sub {
				return 'Hey '.captures->{foo_id}
			}; # GET /foo/123/bar
			resource bar =>
				read => sub {
					return 'foo is '
						. captures->{foo_id}
						.' and bar is '
						. captures->{bar_id}
					}
				}; # GET /foo/123/bar/456
		};

When is return value is a HTTP status code (three digits), C<status(...)> is applied to it. A second return value may be the value to be returned to the client itself:

	sub {
		return 200
	};
	
	sub {
		return 404 => 'This object has not been found.'
	}
	
	sub {
		return 201 => { ... }
	};
	
The default HTTP status code ("200 OK") differs in some actions: C<create> response with "201 Created", C<delete> and C<update> response with "202 Accepted".

=head3 Change of suffix

The appended suffix, C<_id> for default, can be changed by setting C<< $Dancer::Plugin::CRUD::SUFFIX >>. This affects both captures names and the suffix of parameterized C<prefix> method:

	$Dancer::Plugin::CRUD::SUFFIX = 'Id';
	resource 'User' => prefixId => sub { return captures->{'UserId'} };

=head3 Automatic validation of parameters

Synopsis:

    resource foo =>
        validation => {
            generic => {
                checks => [
                    foo_id => Validate::Tiny::is_like(qr{^\d+})
                ]
            },
        },
        read => sub {
            $foo_id = var('validate')->data('foo_id');
        },
	;

The keyword C<validation> specifies rules for L<Validation::Tiny|Validation::Tiny>.

The parameter input resolves to following order: C<params('query')>, C<params('body')>, C<captures()>.

The rules and the result of C<Dancer::params()> are applied to C<Validate::Tiny::new> and stored in C<var('validate')>.

The hashref C<validation> accepts seven keywords:

=over 4

=item I<generic>

These are generic rules, used in every action. For the actions I<index> and I<create>, the fields I<<< C<< $resource >>_id >>> are ignored, since they aren't needed.

=item I<index>, I<create>, I<read>, I<update>, I<delete>

These rules are merged together with I<generic>.

=item I<prefix>, I<prefix_id>

These rules are merged together with I<generic>, but they can only used when C<resource()> is used in the prefix subs.

=item I<wrap>

These rules apply when in a prefix or prefix_id routine the I<wrap> keyword is used:

	resource foo =>
		validation => {
			wrap => {
				GET => {
					bar => {
						fields => [qw[ name ]]
					}
				}
			}
		},
		prefix => sub {
			wrap GET => bar => sub { ... }
		};

=back

The id-fields (I<<< C<< $resource >>_id >>>, ...) are automatically prepended to the I<fields> param of Validate::Tiny. There is no need to define them especially.

An advantage is the feature of stacking resources and to define validation rules only once.

Example:

    resource foo =>
        validation => {
            generic => {
                checks => [
                    foo_id => Validate::Tiny::is_like(qr{^\d+})
                ]
            },
        },
		prefix_id => sub {
			resource bar =>
				validation => {
					generic => {
						checks => [
							bar_id => Validate::Tiny::is_like(qr{^\d+})
						]
					},
				},
				read => sub {
					$foo_id = var('validate')->data('foo_id');
					$bar_id = var('validate')->data('foo_id');
				},
			;
		},
	;

=head3 Chaining actions together

To avoid redundant code, the keyword I<chain> may used to define a coderef executing every times the resource (and possible parent resources) is triggered, irrespective of the method.

Example:

    resource foo =>
		chain => sub { var onetwothree => 123 },
		index => sub { return var('onetwothree') }
        prefix_id => sub {
            resource bar =>
				chain  => sub { var fourfivesix => 456 },
				index  => sub { return var('onetwothree').var('fourfivesix') },
			;
        },
	;

When resource I<foo> is triggered, the variable C<onetwothree> is set to 123. When resource I<bar> is triggered, the variable C<onetwothree> is set to 123 and, of course, C<fourfivesix> is set to 456.

This is useful to obtain parent objects from DB and store it into the var stack.

B<WARNING>: This feature may change in a future release.
	
=cut

register(resource => sub ($%) {
    my $resource = my $resource1 = my $resource2 = shift;
    my %triggers = @_;
    
    {
        my $c = quotemeta '()|{}';
        if ($resource =~ m{[$c]}) {
            $resource1 = pluralize($resource1, 1);
            $resource2 = pluralize($resource2, 2);
        }
    }
	
	my %options;
	push @$stack => \%options;
	
	$options{resname} = $resource1;
	
	my $altsyntax = 0;
	if (exists $triggers{altsyntax}) {
		$altsyntax = delete $triggers{altsyntax};
	}
	
	my $idregex = qr{[^\/\.\:\?]+};

	if (exists $triggers{idregex}) {
		$idregex = delete $triggers{idregex};
	}
    
	$options{prefix} = qr{/\Q$resource2\E};
	$options{prefix_id} = qr{/\Q$resource1\E/(?<$resource1$SUFFIX>$idregex)};
	
	if (exists $triggers{validation}) {
		$options{validation_rules} = delete $triggers{validation};
	}
    
    if (exists $triggers{chain}) {
        $options{chain} = delete $triggers{chain};
    }
	
    if (exists $triggers{'prefix'.$SUFFIX}) {
		my $subref = delete $triggers{'prefix'.$SUFFIX};
		$options{prefixed_with_id} = 1;
		my @prefixes = map { $_->{prefixed_with_id} ? $_->{prefix_id} : $_->{prefix} } grep { exists $_->{prefix} } @$stack;
		local $" = '';
		_prefix(qr{@prefixes}, $subref);
		delete $options{prefixed_with_id};
    }

    if (exists $triggers{prefix}) {
		my $subref = delete $triggers{'prefix'};
		$options{prefixed_with_id} = 0;
		my @prefixes = map { $_->{prefixed_with_id} ? $_->{prefix_id} : $_->{prefix} } grep { exists $_->{prefix} } @$stack;
		local $" = '';
		_prefix(qr{@prefixes}, $subref);
		delete $options{prefixed_with_id};
    }
	
	my %routes;

    foreach my $action (qw(index create read delete update patch)) {
        next unless exists $triggers{$action};

		my $route;
		
		given ($action) {
        	when ('index') {
				$route = qr{/\Q$resource2\E};
			}
			when ('create') {
				$route = qr{/\Q$resource1\E};
			}
			default {
				$route = qr{/\Q$resource1\E/(?<$resource1$SUFFIX>$idregex)};
			}
        }
		
		my $sub = _generate_sub({
			stack => $stack,
			action  => $action,
			coderef => $triggers{$action},
		});
		
		$routes{$action} = [];
		
		if ($altsyntax) {
			push @{$routes{$action}} => $triggers_map{  get  }->(qr{$route/\Q$action\E\.(?<format>json|jsonp|yml|xml|dump)} => $sub);
			push @{$routes{$action}} => $triggers_map{  get  }->(qr{$route/\Q$action\E}                                     => $sub);
		}
		push @{$routes{$action}} => $triggers_map{$action}->(qr{$route\.(?<format>json|jsonp|yml|xml|dump)} => $sub);
		push @{$routes{$action}} => $triggers_map{$action}->(   $route                                      => $sub);
    }
    
	pop @$stack;
	
	return %routes;
});

=head2 C<< wrap >>

This keyword wraps validation rules and format accessors. For return values see C<resource>.

Synopsis:

	resource foo =>
		prefix_id => sub {
			wrap GET => bar => sub {
				# same as get('/bar', sub { ... });
				# and get('/bar.:format', sub { ... });
				# var('validate') is also availble,
				# when key 'validation' is defined
			};
		},
	;

I<wrap> uses the same wrapper as for the actions in I<resource>. Any beviour there also applies here. For a better explaination, these resolves to the same routes:

	resource foo => read => sub { ... };
	wrap read => foo => sub { ... };

The first argument is an CRUD action (I<index>, I<create>, I<read>, I<update>, I<delete>) or a HTTP method (I<GET>, I<POST>, I<PUT>, I<DELETE>, I<PATCH>) and is case-insensitve. The second argument is a route name. A leading slash will be prepended if the route contains to slashes. The third argument is the well known coderef.

Please keep in mind that I<wrap> creates two routes: I<<< /C<< $route >> >>> and I<<< /C<< $route >>.:format >>>.

Returns a list of all created L<Dancer::Route|Dancer::Route> objects.

=cut

register(wrap => sub($$$) {
	my ($action, $route, $coderef) = @_;
	
	my @route = grep { defined and length } split m{/+}, $route;
	
	my $parent = @$stack ? $stack->[-1] : undef;
	foreach my $route (@route) {
		push @$stack => {
			resname => $route
		};
	}
	
	if (defined $parent) {
		if (exists $parent->{validation_rules} and
			exists $parent->{validation_rules}->{wrap} and
			exists $parent->{validation_rules}->{wrap}->{$action} and
			exists $parent->{validation_rules}->{wrap}->{$action}->{$route}
		) {
			$stack->[-1]->{validation_rules} = { lc($action) => $parent->{validation_rules}->{wrap}->{$action}->{$route} };
		}
	}
	
	my $sub = _generate_sub({
		action => lc($action),
		stack => $stack,
		coderef => $coderef,
	});
	
	pop @$stack for @route;
	
	my @routes;
	
	push @routes => $triggers_map{lc($action)}->(qr{/\Q$route\E\.(?<format>json|jsonp|yml|xml|dump)} => $sub);
	push @routes => $triggers_map{lc($action)}->(qr{/\Q$route\E}                                     => $sub);
	
	return @routes;
});

=head2 helpers

Some helpers are available. This helper will set an appropriate HTTP status for you.

=head3 status_ok

    status_ok({users => {...}});

Set the HTTP status to 200

=head3 status_created

    status_created({users => {...}});

Set the HTTP status to 201

=head3 status_accepted

    status_accepted({users => {...}});

Set the HTTP status to 202

=head3 status_bad_request

    status_bad_request("user foo can't be found");

Set the HTTP status to 400. This function as for argument a scalar that will be used under the key B<error>.

=head3 status_not_found

    status_not_found("users doesn't exists");

Set the HTTP status to 404. This function as for argument a scalar that will be used under the key B<error>.

=cut

register send_entity => sub {
    # entity, status_code
    status($_[1] || 200);
    $_[0];
};

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) {
            send_entity({error => $_[0]}, $code);
        }
        else {
            send_entity($_[0], $code);
        }
    };
}

=head1 LICENCE

This module is released under the same terms as Perl itself.

=head1 AUTHORS

This module has been rewritten by David Zurborg C<< <zurborg@cpan.org> >>, based on code written by Alexis Sukrieh C<< <sukria@sukria.net> >> and Franck Cuny.

=head1 SEE ALSO

L<Dancer>
L<http://en.wikipedia.org/wiki/Representational_State_Transfer>
L<Dancer::Plugin::REST>
L<Text::Pluralize>

=head1 AUTHORS

=over 4

=item *

David Zurborg <zurborg@cpan.org>

=item *

Alexis Sukrieh <sukria@sukria.net> (Author of Dancer::Plugin::REST)

=item *

Franck Cuny <franckc@cpan.org> (Author of Dancer::Plugin::REST)

=back

=head1 BUGS

Please report any bugs or feature requests trough my project management tool
at L<http://development.david-zurb.org/projects/libdancer-plugin-crud-perl/issues/new>. I
will be notified, and then you'll automatically be notified of progress on
your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Dancer::Plugin::CRUD

You can also look for information at:

=over 4

=item * Redmine: Homepage of this module

L<http://development.david-zurb.org/projects/libdancer-plugin-crud-perl>

=item * RT: CPAN's request tracker

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Dancer-Plugin-CRUD>

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/Dancer-Plugin-CRUD>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/[Dancer-Plugin-CRUD>

=item * Search CPAN

L<http://search.cpan.org/dist/Dancer-Plugin-CRUD/>

=back

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2014 by David Zurborg <zurborg@cpan.org>.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut

register_plugin;
1;
