Web-MREST/lib/Web/MREST/Resource.pm
# *************************************************************************
# Copyright (c) 2014-2016, SUSE LLC
#
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are met:
#
# 1. Redistributions of source code must retain the above copyright notice,
# this list of conditions and the following disclaimer.
#
# 2. Redistributions in binary form must reproduce the above copyright
# notice, this list of conditions and the following disclaimer in the
# documentation and/or other materials provided with the distribution.
#
# 3. Neither the name of SUSE LLC nor the names of its contributors may be
# used to endorse or promote products derived from this software without
# specific prior written permission.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
# *************************************************************************
# ------------------------
# This package defines how our web server handles the request-response
# cycle. All the "heavy lifting" is done by Web::Machine and Plack.
# ------------------------
package Web::MREST::Resource;
use strict;
use warnings;
use feature "state";
use App::CELL qw( $CELL $log $meta $site );
use App::CELL::Status;
use Data::Dumper;
use JSON;
use Params::Validate qw( :all );
use Plack::Session;
use Try::Tiny;
use Web::MREST::InitRouter qw( $router );
use Web::MREST::Util qw( $JSON );
# methods/attributes not defined in this module will be inherited from:
use parent 'Web::Machine::Resource';
# use this to muffle debug messages in parts of the FSM
my %muffle = (
'1' => 0,
'2' => 1,
'3' => 1,
'4' => 1,
'5' => 0,
);
=head1 NAME
App::MREST::Resource - HTTP request/response cycle
=head1 SYNOPSIS
In C<YourApp/Resource.pm>:
use parent 'Web::MREST::Resource';
In PSGI file:
use Web::Machine;
Web::Machine->new(
resource => 'App::YourApp::Resource',
)->to_app;
It is important to understand that the L<Web::Machine> object created is
actually blessed into C<YourApp::Resource>. The line of inheritance is:
YourApp::Resource
-> Web::MREST::Resource
-> Web::Machine::Resource
-> Plack::Component
=head1 DESCRIPTION
Your application should not call any of the routines in this module directly.
They are called by L<Web::Machine> during the course of request processing.
What your application can do is provide its own versions of selected routines.
=head1 METHODS
=head2 Context methods
Methods for manipulating the context, a hash where we accumulate information
about the request.
=head3 context
Constructor/accessor
=cut
sub context {
my $self = shift;
$self->{'context'} = shift if @_;
if ( ! $self->{'context'} ) {
$self->{'context'} = {};
}
return $self->{'context'};
}
=head3 push_onto_context
Takes a hashref and "pushes" it onto C<< $self->{'context'} >> for use later
on in the course of processing the request.
=cut
sub push_onto_context {
my $self = shift;
my ( $hr ) = validate_pos( @_, { type => HASHREF } );
my $context = $self->context;
foreach my $key ( keys %$hr ) {
$context->{$key} = $hr->{$key};
}
$self->context( $context );
}
=head2 Status declaration methods
Although L<Web::Machine> takes care of setting the HTTP response status code,
but when we have to override L<Web::Machine>'s value we have this "MREST
declared status" mechanism, which places a C<declared_status> property in
the context. During finalization, the HTTP status code placed in this
property overrides the one L<Web::Machine> came up with.
=head3 mrest_declare_status
This method takes either a ready-made L<App::CELL::Status> object or,
alternatively, a PARAMHASH. In the former case, an HTTP status code can be
"forced" on the response by including a C<http_code> property in the
object. In the latter case, the following keys are recognized (and all of
them are optional):
=over
=item level
L<App::CELL::Status> level, can be any of the strings accepted by that module.
Defaults to 'ERR'.
=item code
The HTTP status code to be applied to the response. Include this only if you
need to override the code set by L<Web::Machine>.
=item explanation
Text explaining the status - use this to comply with RFC2616. Defaults to '<NONE>'.
=item permanent
Boolean value for error statuses, specifies whether or not the error is
permanent - use this to comply with RFC2616. Defaults to true.
=back
=cut
sub mrest_declare_status {
my $self = shift;
my @ARGS = @_;
my @caller = caller;
$log->debug( "Entering " . __PACKAGE__ . "::mrest_declare_status with argument(s) " .
Dumper( \@ARGS ) . "\nCaller: " . Dumper( \@caller ) );
# if status gets declared multiple times, keep only the first one
if ( exists $self->context->{'declared_status'} ) {
$log->notice(
"Cowardly refusing to overwrite previously declared status with this one: " .
Dumper( \@ARGS )
);
return;
}
my $declared_status;
if ( @ARGS and ref( $ARGS[0] ) eq 'App::CELL::Status' ) {
#
# App::CELL::Status object was given; bend it to our needs
#
$declared_status = $ARGS[0];
# make sure there is a payload and it is a hashref
if ( ! $declared_status->payload ) {
$declared_status->payload( {} );
}
# if 'http_code' property given, move it to the payload
if ( my $hc = delete( $declared_status->{'http_code'} ) ) {
$log->debug( "mrest_declare_status: HTTP code is $hc" );
$declared_status->payload->{'http_code'} = $hc;
}
# handle 'permanent' property
if ( my $pt = delete( $declared_status->{'permanent'} ) ) {
$declared_status->payload->{'permanent'} = $pt ? JSON::true : JSON::false;
} else {
$declared_status->payload->{'permanent'} = JSON::true;
}
} else {
#
# PARAMHASH was given
#
my %ARGS = validate( @ARGS, {
'level' => { type => SCALAR, default => 'ERR' },
'code' => { type => SCALAR|UNDEF, default => undef },
'explanation' => { type => SCALAR, default => '<NONE>' },
'permanent' => { type => SCALAR, default => 1 },
'args' => { type => ARRAYREF, optional => 1 },
} );
$ARGS{'args'} = [] unless $ARGS{'args'};
$declared_status = App::CELL::Status->new(
level => $ARGS{'level'},
code => $ARGS{'explanation'},
args => $ARGS{'args'},
payload => {
http_code => $ARGS{'code'}, # might be undef
permanent => ( $ARGS{'permanent'} )
? JSON::true
: JSON::false,
},
);
}
# add standard properties to the payload
$declared_status->payload->{'uri_path'} = $self->context->{'uri_path'};
$declared_status->payload->{'resource_name'} = $self->context->{'resource_name'};
$declared_status->payload->{'http_method'} = $self->context->{'method'};
$declared_status->payload->{'found_in'} = {
package => (caller)[0],
file => (caller)[1],
line => (caller)[2]+0,
};
# the object is "done": push it onto the context
$self->push_onto_context( {
'declared_status' => $declared_status,
} );
}
=head3 mrest_declared_status_code
Accessor method, gets just the HTTP status code (might be undef);
and allows setting the HTTP status code, as well, by providing an argument.
=cut
sub mrest_declared_status_code {
my ( $self, $arg ) = @_;
return unless ref( $self->context->{'declared_status'} ) eq 'App::CELL::Status';
my $dsc = $self->context->{'declared_status'}->payload->{'http_code'};
if ( $arg ) {
$log->warn( "Overriding previous declared status code ->" .
( $dsc || 'undefined' ) .
"<- with new value -> " .
( $arg || 'undefined' ) .
"<->" );
$self->context->{'declared_status'}->payload->{'http_code'} = $arg;
$dsc = $arg;
}
return $dsc;
}
=head3 mrest_declared_status_explanation
Accessor method, gets just the explanation (might be undef).
Does not allow changing the explanation - for this, nullify the
declared status and declare a new one.
=cut
sub mrest_declared_status_explanation {
my ( $self, $arg ) = @_;
return unless ref( $self->context->{'declared_status'} ) eq 'App::CELL::Status';
return $self->context->{'declared_status'}->text;
}
=head2 status_declared
Boolean method - checks context for presence of 'declared_status' property. If
it is present, the value of that property is returned, just as if we had done
C<< $self->context->{'declared_status'} >>. Otherwise, undef (false) is returned.
=cut
sub status_declared {
my $self = shift;
if ( my $declared_status_object = $self->context->{'declared_status'} ) {
#$log->debug( "Declared status: " . Dumper( $declared_status_object ) );
if ( ref( $declared_status_object ) ne 'App::CELL::Status' ) {
die "AAAHAAHAAA! Declared status object is not an App::CELL::Status!";
}
return $declared_status_object;
}
return;
}
=head2 declared_status
Synonym for C<status_declared>
=cut
sub declared_status {
my $self = shift;
return $self->status_declared;
}
=head2 nullify_declared_status
This method nullifies any declared status that might be pending.
=cut
sub nullify_declared_status {
my $self = shift;
$log->debug( "Nullifying declared status: " . Dumper( $self->context->{'declared_status'} ) );
delete $self->context->{'declared_status'};
return;
}
=head2 FSM Part One
The following methods override methods defined by L<Web::Machine::Resource>.
They correspond to what the L<Web::MREST> calls "Part One" of the FSM. To muffle
debug-level log messages from this part of the FSM, set $muffle{1} = 1 (above).
=head3 service_available (B13)
This is the first method called on every incoming request.
=cut
sub service_available {
my $self = shift;
$log->debug( "Entering " . __PACKAGE__ . "::service_available (B13)" ) unless $muffle{1};
$self->init_router unless ref( $router ) and $router->can( 'match' );
my $path = $self->request->path_info;
$path =~ s{^\/}{};
my $reported_path = ( $path eq '' )
? 'the root resource'
: $path;
$log->info( "Incoming " . $self->request->method . " request for $reported_path" );
$log->info( "Self is a " . ref( $self ) );
$self->push_onto_context( {
'headers' => $self->request->headers,
'request' => $self->request,
'uri_path' => $path,
'method' => $self->request->method,
} );
return $self->mrest_service_available;
}
=head3 mrest_service_available
Hook. If you overlay this and intend to return false, you should call
C<< $self->mrest_declare_status >> !!
=cut
sub mrest_service_available {
my $self = shift;
$log->debug( "Entering " . __PACKAGE__ . "::mrest_service_available" ) unless $muffle{1};
return 1;
}
=head3 known_methods (B12)
Returns the value of C<MREST_SUPPORTED_HTTP_METHODS> site parameter
=cut
sub known_methods {
my $self = shift;
$log->debug( "Entering " . __PACKAGE__ . "::known_methods (B12)" ) unless $muffle{1};
my $method = $self->context->{'method'};
my $known_methods = $site->MREST_SUPPORTED_HTTP_METHODS || [ qw( GET POST PUT DELETE ) ];
$log->debug( "The known methods are " . Dumper( $known_methods ) ) unless $muffle{1};
if ( ! grep { $method eq $_; } @$known_methods ) {
$log->debug( "$method is not among the known methods" ) unless $muffle{1};
$self->mrest_declare_status( explanation => "The request method $method is not one of the supported methods " . join( ', ', @$known_methods ) );
}
return $known_methods;
}
=head3 uri_too_long (B11)
Is the URI too long?
=cut
sub uri_too_long {
my ( $self, $uri ) = @_;
$log->debug( "Entering " . __PACKAGE__ . "::uri_too_long (B11)" ) unless $muffle{1};
my $max_len = $site->MREST_MAX_LENGTH_URI || 100;
$max_len += 0;
if ( length $uri > $max_len ) {
$self->mrest_declare_status;
return 1;
}
$self->push_onto_context( { 'uri' => $uri } );
return 0;
}
=head3 allowed_methods (B10)
Determines which HTTP methods we recognize for this resource. We return these
methods in an array. If the requested method is not included in the array,
L<Web::Machine> will return the appropriate HTTP error code.
RFC2616 on 405: "The response MUST include an Allow header containing a list of
valid methods for the requested resource." -> this is handled by Web::Machine,
but be aware that if the methods arrayref returned by allowed_methods does
not include the current request method, allow_methods gets called again.
=cut
sub allowed_methods {
my ( $self ) = @_;
$log->debug( "Entering " . __PACKAGE__ . "::allowed_methods (B10)" ) unless $muffle{1};
#
# Does the URI match a known resource?
#
my $path = $self->context->{'uri_path'};
my $method = uc $self->context->{'method'};
$log->debug( "allowed_methods: path is $path, method is $method" ) unless $muffle{1};
if ( my $match = $router->match( $path ) ) {
# path matches resource, but is it defined for this method?
#$log->debug( "match object: " . Dumper( $match ) );
my $resource_name = $match->route->target->{'resource_name'};
$resource_name = ( defined $resource_name )
? $resource_name
: 'NONE_AAGH!';
$self->push_onto_context( {
'match_obj' => $match,
'resource_name' => $resource_name
} );
$log->info( "allowed_methods: $path matches resource ->$resource_name<-" );
my ( $def, @allowed_methods ) = $self->_extract_allowed_methods( $match->route->target );
if ( $def ) {
# method is allowed for this resource; push various values onto the context for later use
$self->_stash_resource_info( $match );
$self->_get_handler( $def );
} else {
# method not allowed for this resource
$self->mrest_declare_status( 'explanation' => "Method not allowed for this resource" );
return \@allowed_methods;
}
if ( $self->status_declared ) {
# something bad happened
return [];
}
# success
return \@allowed_methods;
}
# if path does not match, return an empty arrayref, which triggers a 405 status code
$self->mrest_declare_status( 'code' => 400, 'explanation' => "URI does not match a known resource" );
return [];
}
sub _extract_allowed_methods {
my ( $self, $target ) = @_;
$log->debug( "Entering " . __PACKAGE__ . "::_extract_allowed_methods" ) unless $muffle{1};
#$log->debug( "Target is: " . Dumper( $target ) );
# ---------------------------------------------------------------
# FIXME: need to come up with a more reasonable way of doing this
# ---------------------------------------------------------------
#
# The keys of the $route->target hash are the allowed methods plus:
# - 'resource_name'
# - 'parent'
# - 'children'
# - 'documentation'
#
# So, using set theory we can say that the set of allowed methods
# is equal to the set of $route->target hash keys MINUS the set
# of keys listed above. (This is fine until someone decides to
# add another key to a resource definition and forgets to add it
# here as well.)
#
# ---------------------------------------------------------------
my @allowed_methods;
foreach my $method ( keys %{ $target } ) {
push( @allowed_methods, $method ) unless $method =~ m/(resource_name)|(parent)|(children)|(documentation)/;
}
$log->debug( "Allowed methods are " . join( ' ', @allowed_methods ) ) unless $muffle{1};
return ( $target->{ $self->context->{'method'} }, @allowed_methods );
}
sub _stash_resource_info {
my ( $self, $match ) = @_;
$log->debug( "Entering " . __PACKAGE__ . "::_stash_resource_info" ) unless $muffle{1};
# N.B.: $uri is the base URI, not the path
my $uri = $site->MREST_URI
? $site->MREST_URI
: $self->request->base->as_string;
my $push_hash = {
'mapping' => $match->mapping, # mapping contains values of ':xyz' parts of path
'uri_base' => $uri, # base URI of the REST server
'components' => $match->route->components, # resource components
};
$self->push_onto_context( $push_hash );
#$log->debug( "allowed_methods: pushed onto context " . Dumper( $push_hash ) );
}
sub _get_handler {
my ( $self, $def ) = @_;
$log->debug( "Entering " . __PACKAGE__ . "::_get_handler with resource definition: " . Dumper( $def ) ) unless $muffle{1};
# be idempotent
if ( my $handler_from_context = $self->context->{'handler'} ) {
return $handler_from_context;
}
my $status = 0;
my $handler_name;
if ( $handler_name = $def->{'handler'} ) {
# $handler_name is the name of a method that will hopefully be callable
# by doing $self->$handler_name
$self->push_onto_context( {
'handler' => $handler_name,
} );
} else {
$status = "No handler defined for this resource+method combination!";
}
if ( $status ) {
$self->mrest_declare_status( 'code' => '500', explanation => $status );
$log->err( "Leaving _get_handler with status $status" );
} else {
$log->info( "Leaving _get_handler (all green) - handler is ->$handler_name<-" );
}
}
=head3 malformed_request (B9)
A true return value from this method aborts the FSM and triggers a "400 Bad
Request" response status.
=cut
sub malformed_request {
my ( $self ) = @_;
$log->debug( "Entering " . __PACKAGE__ . "::malformed_request (B9)" ) unless $muffle{1};
# we examing the request body on PUT and POST only (FIXME: make this configurable)
my $method = $self->context->{'method'};
return 0 unless $method =~ m/^(PUT)|(POST)$/;
#$log->debug( "Method is $method" );
# get content-type and content-length
my $content_type = $self->request->headers->header('Content-Type');
$content_type = '<NONE>' unless defined( $content_type );
my $content_length = $self->request->headers->header('Content-Length');
$content_length = '<NONE>' unless defined( $content_length );
#$log->debug( "Content-Type: $content_type, Content-Length: $content_length" );
# no Content-Type and/or no Content-Length, yet request body present ->
# clearly a violation
if ( $self->request->content ) {
if ( $content_type eq '<NONE>' or $content_length eq '<NONE>' ) {
$self->mrest_declare_status(
explanation => 'no Content-Type and/or no Content-Length, yet request body present'
);
return 1;
}
}
$self->push_onto_context( { 'headers' =>
{
'content-length' => $content_length,
'content-type' => $content_type,
}
} );
return $self->mrest_malformed_request;
}
=head3 mrest_malformed_request
Hook
=cut
sub mrest_malformed_request {
my $self = shift;
$log->debug( "Entering " . __PACKAGE__ . "::mrest_malformed_request (B9)" ) unless $muffle{1};
return 0;
}
=head3 is_authorized (B8)
Authentication method - should be implemented in the application.
=cut
sub is_authorized {
my $self = shift;
$log->debug( "Entering " . __PACKAGE__ . "::is_authorized (B8)" ) unless $muffle{1};
return 1;
}
=head3 forbidden (B7)
Authorization method - should be implemented in the application.
=cut
sub forbidden {
my $self = shift;
$log->debug( "Entering " . __PACKAGE__ . "::forbidden (B7)" ) unless $muffle{1};
return 0;
}
=head3 valid_content_headers (B6)
Receives a L<Hash::MultiValue> object containing all the C<Content-*> headers
in the request. Checks these against << $site->MREST_VALID_CONTENT_HEADERS >>,
returns false if the check fails, true if it passes.
=cut
sub valid_content_headers {
my ( $self, $content_headers ) = @_;
$log->debug( "Entering " . __PACKAGE__ . "::valid_content_headers (B6)" ) unless $muffle{1};
$log->debug( "Content headers: " . join( ', ', keys( %$content_headers ) ) ) unless $muffle{1};
# get site param
my $valid_content_headers = $site->MREST_VALID_CONTENT_HEADERS;
die "AAAAAHAHAAAAAHGGGG!! \$valid_content_headers is not an array reference!!"
unless ref( $valid_content_headers ) eq 'ARRAY';
# check these content headers against it
my $valids = _b6_make_hash( $valid_content_headers );
foreach my $content_header ( keys( %$content_headers ) ) {
if ( not exists $valids->{$content_header} ) {
$self->mrest_declare_status( explanation =>
"Content header ->$content_header<- not found in MREST_VALID_CONTENT_HEADERS"
);
return 0;
}
}
return 1;
}
sub _b6_make_hash {
my $ar = shift;
my %h;
foreach my $chn ( @$ar ) {
$chn = 'Content-' . $chn unless $chn =~ m/^Content-/;
$h{ $chn } = '';
}
return \%h;
}
=head3 known_content_type (B5)
The assumption for C<PUT> and C<POST> requests is that they might have an
accompanying request entity, the type of which should be declared via a
C<Content-Type> header. If the content type is not recognized by the
application, return false from this method to trigger a "415 Unsupported Media
Type" response.
The basic content-types (major portions only) accepted by the application
should be listed in C<< $site->MREST_SUPPORTED_CONTENT_TYPES >>. Override this
method if that's not good by you.
=cut
sub known_content_type {
my ( $self, $content_type ) = @_;
$log->debug( "Entering " . __PACKAGE__ . "::known_content_type (B5)" ) unless $muffle{1};
return 1 if not $content_type;
# if $content_type is a blessed object, deal with that
my $ct_isa = ref( $content_type );
if ( $ct_isa ) {
$log->debug( "\$content_type is a ->$ct_isa<-" ) unless $muffle{1};
if ( $ct_isa ne 'HTTP::Headers::ActionPack::MediaType' ) {
$self->mrest_declare_status( code => '500',
explanation => "Bad content_type class ->$ct_isa<-" );
return 0;
}
$content_type = $content_type->type; # convert object to string
}
$log->debug( "Content type of this request is ->$content_type<-" ) unless $muffle{1};
# push it onto context
$self->context->{'content_type'} = $content_type;
# convert supported content types into a hash for easy lookup
my %types = map { ( $_ => '' ); } @{ $site->MREST_SUPPORTED_CONTENT_TYPES };
if ( exists $types{ $content_type } ) {
$log->info( "$content_type is supported" );
return 1;
}
$self->mrest_declare_status( explanation => "Content type ->$content_type<- is not supported" );
return 0;
}
=head3 valid_entity_length (B4)
Called by Web::Machine with one argument: the length of the request
body. Return true or false.
=cut
sub valid_entity_length {
my ( $self, $body_len ) = @_;
state $max_len = $site->MREST_MAX_LENGTH_REQUEST_ENTITY;
$log->debug( "Entering " . __PACKAGE__ . "::valid_entity_length, maximum request entity length is $max_len" ) unless $muffle{1};
$body_len = $body_len || 0;
$log->info( "Request body is $body_len bytes long" );
if ( $body_len > $max_len ) {
$self->mrest_declare_status( explanation => "Request body is $body_len bytes long, which exceeds maximum length set in \$site->MREST_MAX_LENGTH_REQUEST_ENTITY" );
return 0;
}
return 1;
}
=head3 charsets_provided
This method causes L<Web::Machine> to encode the response body (if any) in
UTF-8.
=cut
sub charsets_provided {
return [ qw( UTF-8 ) ];
}
#=head3 default_charset
#
#Really use UTF-8 all the time.
#
#=cut
#
#sub default_charset { 'utf8'; }
=head2 FSM Part Two (Content Negotiation)
See L<Web::MREST::Entity>.
=head2 FSM Part Three (Resource Existence)
=head2 resource_exists (G7)
The initial check for resource existence is the URI-to-resource mapping,
which has already taken place in C<allowed_methods>. Having made it to here,
we know that was successful.
So, what we do here is call the handler function, which is expected to
return an L<App::CELL::Status> object. How this status is interpreted is
left up to the application: we pass the status object to the
C<mrest_resource_exists> method, which should return either true or false.
For GET and POST, failure means 404 by default, but can be overrided
by calling C<mrest_declare_status> from within C<mrest_resource_exists>.
For PUT, success means this is an update operation and failure means insert.
For DELETE, failure means "202 Accepted" - i.e. a request to delete a
resource that doesn't exist is accepted, but nothing actually happens.
=cut
sub resource_exists {
my $self = shift;
$log->debug( "Entering " . __PACKAGE__ . "::resource_exists" );
#$log->debug( "Context is " . Dumper( $self->context ) );
# no handler is grounds for 500
if ( not exists $self->context->{'handler'} ) {
$self->mrest_declare_status( code => '500',
explanation => 'AAAAAAAAAAGAHH!!! In resource_exists, no handler/mapping on context' );
return 0;
}
#
# run handler (first pass) and push result onto context
#
my $handler = $self->context->{'handler'};
$log->debug( "resource_exists: Calling resource handler $handler for the first time" );
my $bool;
try {
$bool = $self->$handler(1);
} catch {
$self->mrest_declare_status( code => 500, explanation => $_ );
$bool = 0;
};
$self->push_onto_context( { 'resource_exists' => $bool } );
return 1 if $bool;
# Application thinks the resource doesn't exist. Return value will be
# 0. For GET and DELETE, this should trigger 404 straightaway: make
# sure the status is declared so we don't send back a bare response.
# For POST, the next method will be 'allow_missing_post'.
# For PUT, it will be ...?...
if ( not $self->status_declared ) {
my $method = $self->context->{'method'};
my $explanation = "Received request for non-existent resource";
if ( $method eq 'GET' ) {
# 404 will be assigned by Web::Machine
$self->mrest_declare_status( 'explanation' => $explanation );
} elsif ( $method eq 'DELETE' ) {
# for DELETE, Web::Machine would ordinarily return a 202 so
# we override that
$self->mrest_declare_status( 'code' => 404, 'explanation' => $explanation );
}
}
return 0;
}
=head2 allow_missing_post
If the application wishes to allow POST to a non-existent resource, this
method will need to be overrided.
=cut
sub allow_missing_post {
my ( $self ) = @_;
$log->debug( "Entering " . __PACKAGE__ . "::allow_missing_post" );
# we do not allow POST to a non-existent resource, so we declare 404
$self->mrest_declare_status( 'code' => 404, explanation =>
'Detected attempt to POST to non-existent resource' ) unless $self->status_declared;
return 0;
}
=head2 post_is_create
=cut
sub post_is_create {
my $self = shift;
$log->debug( "Entering " . __PACKAGE__ . "::post_is_create" );
return $self->mrest_post_is_create;
}
=head2 mrest_post_is_create
Looks for a 'post_is_create' property in the context and returns
1 or 0, as appropriate.
=cut
sub mrest_post_is_create {
my $self = shift;
$log->debug( "Entering " . __PACKAGE__ . "::mrest_post_is_create" );
my $pic = $self->context->{'post_is_create'};
if ( ! defined( $pic ) ) {
$log->error( "post_is_create property is missing; defaults to false" );
return 0;
}
if ( $pic ) {
$log->info( "post_is_create property is true" );
return 1;
}
$log->info( "post_is_create property is false" );
return 0;
}
=head2 create_path
=cut
sub create_path {
my $self = shift;
$log->debug( "Entering " . __PACKAGE__ . "::create_path" );
# if there is a declared status, return a dummy value
return "DUMMY" if $self->status_declared;
return $self->mrest_create_path;
}
=head2 mrest_create_path
This should always return _something_ (never undef)
=cut
sub mrest_create_path {
my $self = shift;
$log->debug( "Entering " . __PACKAGE__ . "::mrest_create_path" );
my $create_path = $self->context->{'create_path'};
if ( ! defined( $create_path ) ) {
$site->mrest_declare_status( code => 500,
explanation => "Post is create, but create_path missing in handler status" );
return 'ERROR';
}
$log->debug( "Returning create_path " . Dumper( $create_path ) );
return $create_path;
}
=head2 create_path_after_handler
This is set to true so we can set C<< $self->context->{'create_path'} >> in the handler.
=cut
sub create_path_after_handler { 1 }
=head2 process_post
This is where we construct responses to POST requests that do not create
a new resource. Since we expect our resource handlers to "do the needful",
all we need to do is call the resource handler for pass two.
The return value should be a Web::Machine/HTTP status code
like, e.g., \200 - this ensures that Web::Machine does not attempt to
encode the response body, as in our case this would introduce a double-
encoding bug.
=cut
sub process_post {
my $self = shift;
$log->debug("Entering " . __PACKAGE__ . "::process_post" );
# Call the request handler. This way is bad, because it ignores any
# 'Accept' header provided in the request by the user agent. However, until
# Web::Machine is patched we have no other way of knowing the request
# handler's name so we have to hard-code it like this.
#$self->_load_request_entity;
#my $status = $self->mrest_process_request;
#return $status if ref( $status ) eq 'SCALAR';
#
#return \200 if $self->context->{'handler_status'}->ok;
#
# if the handler status is not ok, there SHOULD be a declared status
#return $self->mrest_declared_status_code || \500;
my $status = $self->mrest_process_request;
$log->debug( "Handler returned: " . Dumper( $status ) );
return $status;
}
=head2 delete_resource
This method is called on DELETE requests and is supposed to tell L<Web::Machine>
whether or not the DELETE operation was enacted. In our case, we call the
resource handler (pass two).
=cut
sub delete_resource {
my $self = shift;
$log->debug("Entering " . __PACKAGE__ . "::delete_resource");
my $status = $self->mrest_generate_response;
return 0 if ref( $status ) eq 'SCALAR' or $self->context->{'handler_status'}->not_ok;
return 1;
};
=head2 finish_request
This overrides the Web::Machine method of the same name, and is called just
before the final response is constructed and sent. We use it for adding certain
headers in every response.
=cut
sub finish_request {
my ( $self, $metadata ) = @_;
state $http_codes = $site->MREST_HTTP_CODES;
$log->debug( "Entering " . __PACKAGE__ . "::finish_request with metadata: " . Dumper( $metadata ) );
if ( ! $site->MREST_CACHE_ENABLED ) {
#
# tell folks not to cache
#
$self->response->header( 'Cache-Control' => $site->MREST_CACHE_CONTROL_HEADER );
$self->response->header( 'Pragma' => 'no-cache' );
}
#
# when Web::Machine catches an exception, it sends us the text in the
# metadata -- in practical terms, this means: if the metadata contains an
# 'exception' property, something died somewhere
#
if ( $metadata->{'exception'} ) {
my $exception = $metadata->{'exception'};
$exception =~ s/\n//g;
$self->mrest_declare_status( code => '500', explanation => $exception );
}
#
# if there is a declared status, we assume that it contains the entire
# intended response and clobber $self->response->content with it
#
if ( $self->status_declared ) {
my $declared_status = $self->context->{'declared_status'};
$log->debug( "finish_request: declared status is " . Dumper( $declared_status ) );
if ( ! $declared_status->payload->{'http_code'} ) {
$declared_status->payload->{'http_code'} = $self->response->code;
} else {
$self->response->code( $declared_status->payload->{'http_code'} );
}
my $json = $JSON->encode( $declared_status->expurgate );
$self->response->content( $json );
$self->response->header( 'content-length' => length( $json ) );
}
# The return value is ignored, so any effect of this method must be by
# modifying the response.
$log->debug( "Response finalized: " . Dumper( $self->response ) );
return;
}
1;