package CatalystX::CRUD::Controller::REST;
use Moose;
use namespace::autoclean;
use Data::Dump qw( dump );
BEGIN {
extends qw( Catalyst::Controller::REST CatalystX::CRUD );
}
our $VERSION = '0.004';
__PACKAGE__->mk_accessors(
qw(
model_adapter
model_name
model_meta
primary_key
naked_results
page_size
)
);
with 'CatalystX::CRUD::ControllerRole';
use CatalystX::CRUD::Results;
=head1 NAME
CatalystX::CRUD::Controller::REST - Catalyst::Controller::REST with CRUD
=head1 SYNOPSIS
package MyApp::Controller::Foo;
use Moose;
use namespace::autoclean;
BEGIN { extends 'CatalystX::CRUD::Controller::REST' }
__PACKAGE__->config(
model_name => 'Foo',
primary_key => 'id',
page_size => 50,
);
1;
# now you can manage Foo objects with URIs like:
# POST /foo -> create new Foo record
# GET /foo -> list all Foo records
# PUT /foo/<pk> -> create or update Foo record (idempotent)
# DELETE /foo/<pk> -> delete Foo record
# GET /foo/<pk> -> view Foo record
# GET /foo/<pk>/bar -> view Bar object(s) related to Foo
# POST /foo/<pk>/bar -> create Bar object related to Foo
# GET /foo/<pk>/bar/<pk2> -> view Bar with id <pk2> related to Foo with <pk>
# POST /foo/<pk>/bar/<pk2> -> create relationship between Foo <pk> and Bar <pk2>
# DELETE /foo/<pk>/bar/<pk2> -> sever Bar object relationship to Foo
# PUT /foo/<pk>/bar/<pk2> -> create/update Bar object related to Foo (idempotent)
# GET /foo/search -> search for Foo objects
# GET /foo/count -> search for Foo objects, returning count only
=head1 DESCRIPTION
Subclass of Catalyst::Controller::REST for use with CatalystX::CRUD.
=head1 DISCLAIMERS
This module is B<not> to be confused with CatalystX::CRUD::REST.
This is not a drop-in replacement for existing CatalystX::CRUD::Controllers.
This module extends Catalyst::Controller::REST to work with the
CatalystX::CRUD::Controller API. It is designed for web services,
not managing CRUD actions via HTML forms.
This is B<not> a subclass of CatalystX::CRUD::Controller.
=cut
=head1 METHODS
=cut
##############################################################
# Local actions
=head2 search_objects
Registers URL space for B<search>.
=cut
sub search_objects : Path('search') : Args(0) : ActionClass('REST') {
}
=head2 search_objects_GET
Query the model and return results. See do_search().
=cut
sub search_objects_GET {
my ( $self, $c ) = @_;
$self->do_search($c);
if ( !blessed( $c->stash->{results} ) ) {
$self->status_bad_request( $c,
message => 'Must provide search parameters' );
}
else {
$self->status_ok( $c, entity => $c->stash->{results}->serialize );
}
}
=head2 count_objects
Registers URL space for B<count>.
=cut
sub count_objects : Path('count') : Args(0) : ActionClass('REST') {
}
=head2 count_objects_GET
Like search_objects_GET() but does not set result values, only a total count.
Useful for AJAX-y types of situations where you want to query for a total
number of matches and create a pager but not actually retrieve any data.
=cut
sub count_objects_GET {
my ( $self, $c ) = @_;
$c->stash( fetch_no_results => 1 ); # optimize a little
$self->do_search($c);
if ( !blessed( $c->stash->{results} ) ) {
$self->status_bad_request( $c,
message => 'Must provide search parameters' );
}
else {
$self->status_ok( $c, entity => $c->stash->{results}->serialize );
}
}
##############################################################
# REST actions
=head2 zero_args
Registers URL space for 0 path arguments.
=cut
sub zero_args : Path('') : Args(0) : ActionClass('REST') {
}
=head2 zero_args_GET( I<ctx> )
GET /foo -> list objects of type foo.
Calls do_search().
=cut
sub zero_args_GET {
my ( $self, $c ) = @_;
$self->do_search($c);
$self->status_ok( $c, entity => $c->stash->{results}->serialize );
}
=head2 zero_args_POST( I<ctx> )
POST /foo -> create object of type foo.
=cut
sub zero_args_POST {
my ( $self, $c ) = @_;
unless ( $self->can_write($c) ) {
$self->status_forbidden( $c, message => 'Permission denied' );
return;
}
$c->stash( object => $self->do_model( $c, 'fetch' ) );
if ( my $obj = $self->save_object($c) ) {
my $pk = $self->make_primary_key_string($obj);
$self->status_created(
$c,
location => $c->uri_for($pk),
entity => $c->stash->{object}->serialize
);
}
else {
# TODO msg
$self->status_bad_request( $c, message => 'Failed to create' );
}
}
=head2 one_arg
Registers URL space for 1 path argument.
=cut
sub one_arg : Path('') : Args(1) : ActionClass('REST::ForBrowsers') {
my ( $self, $c, $id ) = @_;
$self->fetch( $c, $id );
}
=head2 one_arg_GET( I<ctx>, I<pk> )
GET /foo/<pk> -> retrieve object for I<pk>.
=cut
sub one_arg_GET {
my ( $self, $c, $id ) = @_;
return if $c->stash->{fetch_failed};
return if $c->stash->{object}->is_new; # 404
$self->status_ok( $c, entity => $c->stash->{object}->serialize );
}
=head2 one_arg_PUT( I<ctx>, I<pk> )
PUT /foo/<pk> -> create or update the object for I<pk>.
This method must be idempotent. POST is not.
=cut
sub one_arg_PUT {
my ( $self, $c, $id ) = @_;
return if $c->stash->{fetch_failed};
# remember if we're creating or updating
my $obj_is_new = $c->stash->{object}->is_new;
unless ( $self->can_write($c) ) {
$self->status_forbidden( $c, message => 'Permission denied' );
return;
}
if ( my $obj = $self->save_object($c) ) {
if ( !$obj_is_new ) {
$self->status_ok( $c, entity => $obj->serialize );
}
else {
my $loc = $c->uri_for($id);
$c->log->debug("PUT location=$loc") if $c->debug;
$self->status_created(
$c,
location => $loc,
entity => $obj->serialize,
);
}
}
else {
# TODO msg
$self->status_bad_request( $c, message => 'Failed to update' );
}
}
=head2 one_arg_DELETE( I<ctx>, I<pk> )
DELETE /foo/<pk> -> delete the object for I<pk>.
=cut
sub one_arg_DELETE {
my ( $self, $c, $id ) = @_;
return if $c->stash->{fetch_failed};
unless ( $self->can_write($c) ) {
$self->status_forbidden( $c, message => 'Permission denied' );
return;
}
if ( $self->delete_object($c) ) {
$self->status_no_content($c);
}
else {
# TODO msg
$self->status_bad_request( $c, message => 'Failed to delete' );
}
}
=head2 two_args
Registers URL space for 2 path arguments.
=cut
sub two_args : Path('') : Args(2) : ActionClass('REST::ForBrowsers') {
my ( $self, $c, $id, $rel ) = @_;
$c->stash( rel_name => $rel );
$self->fetch( $c, $id );
}
=head2 two_args_GET( I<ctx>, I<pk>, I<rel> )
GET /foo/<pk>/bar -> a list of objects of type bar related to foo.
=cut
sub two_args_GET {
my ( $self, $c, $id, $rel ) = @_;
return if $c->stash->{fetch_failed};
my $results
= $self->do_model( $c, 'iterator_related', $c->stash->{object}, $rel,
);
if ( $self->has_errors($c) ) {
my $err = $c->error->[0];
if ( $err =~ m/^(unsupported relationship name: (\S+))/i ) {
$self->status_not_found( $c, message => $1 );
}
else {
$self->status_bad_request( $c, message => $err );
}
$c->clear_errors;
}
else {
$self->status_ok( $c, entity => $results->serialize );
}
}
=head2 two_args_POST( I<ctx>, I<pk>, I<rel> )
POST /foo/<pk>/bar -> create relationship between foo and bar.
B<TODO> This method calls a not-yet-implemented create_related()
action in the CXC::Model.
=cut
sub two_args_POST {
my ( $self, $c, $id, $rel ) = @_;
return if $c->stash->{fetch_failed};
unless ( $self->can_write($c) ) {
$self->status_forbidden( $c, message => 'Permission denied' );
return;
}
$self->throw_error('TODO');
my $rel_obj
= $self->do_model( $c, 'create_related', $c->stash->{object}, $rel, );
if ($rel_obj) {
my $rel_id = $self->make_primary_key_string($rel_obj);
$self->status_created(
$c,
location =>
$c->uri_for( sprintf( "%s/%s/%s", $id, $rel, $rel_id ) ),
entity => $rel_obj->serialize
);
}
else {
# TODO msg
$self->status_bad_request( $c, message => 'Failed to delete' );
}
}
=head2 three_args
Registers the URL space for 3 path arguments.
=cut
sub three_args : Path('') : Args(3) : ActionClass('REST::ForBrowsers') {
my ( $self, $c, $id, $rel, $rel_id ) = @_;
$c->stash( rel_name => $rel );
$c->stash( foreign_pk_value => $rel_id );
$self->fetch( $c, $id );
}
=head2 three_args_GET( I<ctx>, I<pk>, I<rel>, I<rel_id> )
GET /foo/<pk>/<re>/<pk2>
=cut
sub three_args_GET {
my ( $self, $c, $id, $rel, $rel_id ) = @_;
return if $c->stash->{fetch_failed};
my $result
= $self->do_model( $c, 'find_related', $c->stash->{object}, $rel,
$rel_id, );
if ( !$result or ( ref $result eq 'ARRAY' and !@$result ) ) {
my $err_msg = sprintf( "No such %s with id '%s'", $rel, $rel_id );
$self->status_not_found( $c, message => $err_msg );
}
else {
# coerce $result into an array ref for consistency
if ( ref $result ne 'ARRAY' ) {
$result = [$result];
}
my @entity;
for my $r (@$result) {
push @entity, $r->serialize;
}
$self->status_ok( $c, entity => \@entity );
}
}
=head2 three_args_DELETE( I<ctx>, I<pk>, I<rel>, I<rel_pk> )
DELETE /foo/<pk>/bar/<pk2> -> sever 'bar' object relationship to 'foo'
=cut
sub three_args_DELETE {
my ( $self, $c, $id, $rel, $rel_id ) = @_;
return if $c->stash->{fetch_failed};
unless ( $self->can_write($c) ) {
$self->status_forbidden( $c, message => 'Permission denied' );
return;
}
my $rt = $self->do_model( $c, 'rm_related', $c->stash->{object}, $rel,
$rel_id, );
if ($rt) {
$self->status_no_content($c);
}
else {
# TODO msg
$self->status_bad_request( $c,
message => 'Failed to remove relationship' );
}
}
=head2 three_args_POST( I<ctx>, I<pk>, I<rel>, I<rel_pk> )
POST /foo/<pk>/bar/<pk2> -> create relationship between 'foo' and 'bar'
=cut
sub three_args_POST {
my ( $self, $c, $id, $rel, $rel_id ) = @_;
return if $c->stash->{fetch_failed};
my $rt = $self->do_model( $c, 'add_related', $c->stash->{object}, $rel,
$rel_id, );
if ($rt) {
$self->status_no_content($c);
}
else {
# TODO msg
$self->status_bad_request( $c,
message => 'Failed to create relationship' );
}
}
=head2 three_args_PUT( I<ctx>, I<pk>, I<rel>, I<rel_pk> )
PUT /foo/<pk>/bar/<pk2> -> create/update 'bar' object related to 'foo'
=cut
sub three_args_PUT {
my ( $self, $c, $id, $rel, $rel_id ) = @_;
return if $c->stash->{fetch_failed};
my $rt = $self->do_model( $c, 'put_related', $c->stash->{object}, $rel,
$rel_id, );
if ($rt) {
$self->status_no_content($c);
}
else {
# TODO msg
$self->status_bad_request( $c,
message => 'Failed to PUT relationship' );
}
}
##########################################################
# CRUD methods
=head2 save_object( I<ctx> )
Calls can_write(), inflate_object(), precommit(), create_or_update_object()
and postcommit().
=cut
sub save_object {
my ( $self, $c ) = @_;
unless ( $self->can_write($c) ) {
$self->status_forbidden( $c, message => 'Permission denied' );
return;
}
# get a valid object
my $obj = $self->inflate_object($c);
if ( !$obj ) {
$c->log->debug("inflate_object() returned false") if $c->debug;
return 0;
}
# write our changes
unless ( $self->precommit( $c, $obj ) ) {
return 0;
}
$self->create_or_update_object( $c, $obj );
$self->postcommit( $c, $obj );
return $obj;
}
=head2 create_or_update_object( I<ctx>, I<object> )
Calls the update() or create() method on the I<object> (or model_adapter()),
picking the method based on whether C<object_id> in stash()
evaluates true (update) or false (create).
=cut
sub create_or_update_object {
my ( $self, $c, $obj ) = @_;
my $method = $obj->is_new ? 'create' : 'update';
$c->log->debug("object->$method") if $c->debug;
if ( $self->model_adapter ) {
$self->model_adapter->$method( $c, $obj );
}
else {
$obj->$method;
}
}
=head2 delete_object( I<ctx> )
Checks can_write(), precommit(), and if both true,
calls the delete() method on the B<object> in the stash().
=cut
sub delete_object {
my ( $self, $c ) = @_;
unless ( $self->can_write($c) ) {
$self->status_forbidden( $c, message => 'Permission denied' );
return;
}
my $o = $c->stash->{object};
unless ( $self->precommit( $c, $o ) ) {
return 0;
}
if ( $self->model_adapter ) {
$self->model_adapter->delete( $c, $o );
}
else {
$o->delete;
}
$self->postcommit( $c, $o );
return 1;
}
=head2 inflate_object( I<ctx> )
Returns the object from stash() initialized with the request data.
=cut
sub inflate_object {
my ( $self, $c ) = @_;
my $object = $c->stash->{object};
if ( !$object ) {
$self->throw_error("object not set in stash");
}
my $req_data = $c->req->data;
if ( !$req_data ) {
$self->status_bad_request( $c, message => 'Missing request data' );
return;
}
# TODO other sanity checks?
for my $f ( keys %$req_data ) {
if ( $object->can($f) ) {
$object->$f( $req_data->{$f} );
}
}
return $object;
}
=head2 can_read( I<ctx> )
Returns true if the current request is authorized to read() the C<object> in
stash().
Default is true.
=cut
sub can_read {1}
=head2 can_write( I<ctx> )
Returns true if the current request is authorized to create() or update()
the C<object> in stash().
Default is true.
=cut
sub can_write {1}
=head2 precommit( I<ctx>, I<object> )
Called by save_object(). If precommit() returns a false value, save_object() is aborted.
If precommit() returns a true value, create_or_update_object() gets called.
The default return is true.
=cut
sub precommit {1}
=head2 postcommit( I<cxt>, I<obj> )
Called internally inside save_object(). Our default just returns true.
Override this method to post-process a successful save_object() action.
=cut
sub postcommit {1}
=head2 fetch( I<ctx>, I<pk> )
Determines the correct value and field name for I<pk>
and calls the do_model() method for C<fetch>.
On success, the B<object> key will be set in stash().
On failure, calls status_not_found() and sets the
B<fetch_failed> stash() key.
=cut
sub fetch {
my ( $self, $c, $id ) = @_;
unless ( $self->can_read($c) ) {
$self->status_forbidden( $c, message => 'Permission denied' );
return;
}
$c->stash->{object_id} = $id;
my @pk = $self->get_primary_key( $c, $id );
# make sure all elements of the @pk pairs are not-null
if ( scalar(@pk) % 2 ) {
$self->throw_error(
"Odd number of elements returned from get_primary_key()");
}
my %pk_pairs = @pk;
my $pk_is_null;
for my $key ( keys %pk_pairs ) {
my $val = $pk_pairs{$key};
if ( !defined($val) or !length($val) ) {
$pk_is_null = $key;
last;
}
}
if ( $c->debug and defined $pk_is_null ) {
$c->log->debug("Null PK value for '$pk_is_null'");
}
my @arg = ( defined $pk_is_null || !$id ) ? () : (@pk);
$c->log->debug( "fetch: " . dump \@arg ) if $c->debug;
$c->stash->{object} = $self->do_model( $c, 'fetch', @arg );
if ( !$c->stash->{object} ) {
my $err_msg
= sprintf( "No such %s with id '%s'", $self->model_name, $id );
$self->status_not_found( $c, message => $err_msg );
$c->log->error($err_msg);
$c->stash( fetch_failed => 1 );
$c->clear_errors;
return 0;
}
if ( $self->has_errors($c) ) {
$c->log->debug("errors in fetch") if $c->debug;
}
return $c->stash->{object};
}
=head2 do_search( I<ctx>, I<arg> )
Prepare and execute a search. Called internally by list()
and search().
Results are saved in stash() under the C<results> key.
If B<naked_results> is true, then results are set just as they are
returned from search() or list() (directly from the Model).
If B<naked_results> is false (default), then results is a
CatalystX::CRUD::Results object.
=cut
sub do_search {
my ( $self, $c, @arg ) = @_;
# if we have no input, just return for initial search
if ( !@arg && !$c->req->param && $c->action->name eq 'search' ) {
return;
}
my $query;
if ( $self->can('make_query') ) {
$query = $self->make_query( $c, @arg );
}
elsif ( $self->model_can( $c, 'make_query' ) ) {
$query = $self->do_model( $c, 'make_query', @arg );
}
else {
$self->throw_error(
"neither controller nor model implement a make_query() method");
}
my $count = $self->do_model( $c, 'count', $query ) || 0;
my $results;
unless ( $c->stash->{fetch_no_results} ) {
$results = $self->do_model( $c, 'search', $query );
}
my $pager;
if ( $count && $self->model_can( $c, 'make_pager' ) ) {
$pager = $self->do_model( $c, 'make_pager', $count, $results );
}
my $r
= $self->naked_results
? $results
: CatalystX::CRUD::Results->new(
{ count => $count,
pager => $pager,
results => $results,
query => $query,
}
);
$c->stash( results => $r );
}
=head2 do_model( I<ctx>, I<args> )
Wrapper around the ControllerRole method of the same name.
The wrapper does an eval and sets the I<ctx> error param
with $@.
=cut
around 'do_model' => sub {
my ( $orig, $self, $c, @args ) = @_;
my $results;
eval { $results = $self->$orig( $c, @args ); };
if ($@) {
$c->error($@); # re-throw
return $results;
}
return $results;
};
1;
__END__
=head1 AUTHOR
Peter Karman, C<< <karman at cpan.org> >>
=head1 BUGS
Please report any bugs or feature requests to C<bug-catalystx-crud-controller-rest at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CatalystX-CRUD-Controller-REST>. 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 CatalystX::CRUD::Controller::REST
You can also look for information at:
=over 4
=item * Mailing List
L<https://groups.google.com/forum/#!forum/catalystxcrud>
=item * RT: CPAN's request tracker
L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=CatalystX-CRUD-Controller-REST>
=item * AnnoCPAN: Annotated CPAN documentation
L<http://annocpan.org/dist/CatalystX-CRUD-Controller-REST>
=item * CPAN Ratings
L<http://cpanratings.perl.org/d/CatalystX-CRUD-Controller-REST>
=item * Search CPAN
L<http://search.cpan.org/dist/CatalystX-CRUD-Controller-REST/>
=back
=head1 COPYRIGHT & LICENSE
Copyright 2012 Peter Karman.
This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.
See http://dev.perl.org/licenses/ for more information.
=cut