Apache2-API
view release on metacpan or search on metacpan
lib/Apache2/API.pm view on Meta::CPAN
$r ||= Apache2::RequestUtil->request;
return( $self->error( "No Apache2::RequestRec object was provided." ) ) if( !$r );
$self->apache_request( $r ) || return( $self->pass_error );
}
my( $req, $resp );
unless( $req = $self->request )
{
$req = Apache2::API::Request->new( $r, debug => $self->debug ) ||
return( $self->pass_error( Apache2::API::Request->error ) );
$self->request( $req );
}
unless( $resp = $self->response )
{
$resp = Apache2::API::Response->new( request => $req, debug => $self->debug ) ||
return( $self->pass_error( Apache2::API::Response->error ) );
$self->response( $resp );
}
return( $self );
}
sub apache_request { return( shift->_set_get_object_without_init( 'apache_request', 'Apache2::RequestRec', @_ ) ); }
sub apr1_md5
{
my( $passwd, $salt ) = @_;
my $ht = Apache2::API::Password->new( $passwd, create => 1, algo => 'md5', ( defined( $salt ) ? ( salt => $salt ) : () ) ) ||
die( Apache2::API::Password->error );
return( $ht->hash );
}
sub bailout
{
my $self = shift( @_ );
my $msg;
if( scalar( @_ ) == 1 && ref( $_[0] ) eq 'HASH' )
{
$msg = shift( @_ );
}
elsif( scalar( @_ ) == 1 && $self->_is_a( $_[0] => 'Module::Generic::Exception' ) )
{
my $ex = shift( @_ );
$msg = {};
if( my $code = $ex->code )
{
$msg->{code} = $code;
}
else
{
$msg->{code} = Apache2::Const::HTTP_INTERNAL_SERVER_ERROR;
}
$msg->{message} = $ex->message;
my $lang;
if( $ex->can( 'type' ) && ( my $type = $ex->type ) )
{
$msg->{type} = $type;
}
if( !$msg->{lang} && $ex->can( 'lang' ) && ( $lang = $ex->lang ) )
{
$msg->{lang} = $lang;
}
elsif( !$msg->{lang} && $ex->can( 'locale' ) && ( $lang = $ex->locale ) )
{
$msg->{lang} = $lang;
}
warn( $msg->{message} ) if( $msg->{message} );
}
else
{
$msg = { code => Apache2::Const::HTTP_INTERNAL_SERVER_ERROR };
$msg->{message} = join( '', @_ ) if( @_ );
}
# We send the error to our error method
$msg->{code} ||= Apache2::Const::HTTP_INTERNAL_SERVER_ERROR;
$self->error( $msg ) if( $msg->{message} );
CORE::delete( $msg->{skip_frames} );
# So it gets logged or displayed on terminal
my( $pack, $file, $line ) = caller;
my $sub_str = ( caller(1) )[3];
my $sub = CORE::index( $sub_str, '::' ) != -1 ? substr( $sub_str, rindex( $sub_str, '::' ) + 2 ) : $sub_str;
# Now we tweak the hash to send it to the client
$msg->{message} = CORE::delete( $msg->{public_message} ) || 'An unexpected server error has occurred';
# Give it a chance to be localised
$msg->{message} = $self->gettext( $msg->{message} );
# For example, if the message is a Text::PO::Gettext::String object
if( !$msg->{lang} && $self->_can( $msg->{message} => 'lang' ) )
{
$msg->{lang} = $msg->{message}->lang;
}
elsif( !$msg->{lang} && $self->_can( $msg->{message} => 'locale' ) )
{
$msg->{lang} = $msg->{message}->locale;
}
my $ctype = $self->response->content_type;
if( $ctype eq 'application/json' )
{
return( $self->reply( $msg->{code}, { error => $msg->{message} } ) );
}
else
{
# try-catch
local $@;
my $rv = eval
{
my $r = $self->apache_request;
$r->status( $msg->{code} );
$r->rflush;
$r->print( $msg->{message} );
return( $msg->{code} );
};
if( $@ )
{
return( Apache2::Const::HTTP_INTERNAL_SERVER_ERROR );
}
return( $rv );
}
}
sub compression_threshold { return( shift->_set_get_number( 'compression_threshold', @_ ) ); }
# <https://perl.apache.org/docs/2.0/api/APR/Base64.html#toc_C_decode_>
sub decode_base64
{
my $self = shift( @_ );
my $data = shift( @_ );
# try-catch
local $@;
my $rv = eval
{
return( APR::Base64::decode( $data ) );
};
if( $@ )
{
return( $self->error( "An error occurred while trying to base64 decode data: $@" ) );
}
return( $rv );
}
sub decode_json
{
my $self = shift( @_ );
my $raw = shift( @_ ) || return( $self->error( "No json data was provided to decode." ) );
my $json = $self->json;
my $hash;
# try-catch
local $@;
eval
{
$hash = $json->utf8->decode( $raw );
};
if( $@ )
{
lib/Apache2/API.pm view on Meta::CPAN
$self->response->headers->merge( 'Vary' => 'Accept-Encoding' );
# $r->send_http_header;
$z->print( $json );
$z->close;
}
elsif( CORE::length( $json ) > $threshold &&
$self->request->accept_encoding =~ /\bdeflate\b/i &&
$self->_load_class( 'IO::Compress::Deflate' ) &&
( $z = IO::Compress::Deflate->new( '-' ) ) )
{
## $r->content_encoding( 'deflate' );
$self->response->content_encoding( 'deflate' );
$self->response->headers->set( 'Content-Encoding' => 'deflate' );
$self->response->headers->merge( 'Vary' => 'Accept-Encoding' );
# $r->send_http_header;
$z->print( $json );
$z->close;
}
else
{
$self->response->headers->unset( 'Content-Encoding' );
# $self->response->content_encoding( undef() );
# $r->send_http_header;
# $r->print( $json );
# $json = Encode::encode_utf8( $json ) if( utf8::is_utf8( $json ) );
# try-catch
local $@;
eval
{
my $bytes = $r->print( $json );
};
if( $@ )
{
}
}
# $r->rflush;
# Flush any buffered data to the client using Apache2::RequestIO
$self->response->rflush;
return( $self );
}
# push_handlers($hook_name => \&handler);
# push_handlers($hook_name => [\&handler, \&handler2]);
sub push_handlers { return( shift->_try( 'server', 'push_handlers', @_ ) ); }
# See also <https://developer.mozilla.org/en-US/docs/Web/HTTP/Reference/Status/406>
sub reply
{
my $self = shift( @_ );
my( $code, $ref );
my $use_rfc_error = $self->{use_rfc_error} // $USE_RFC_ERROR;
# rfc9457 standard for REST API error response: <https://www.rfc-editor.org/rfc/rfc9457.html>
# Legacy JSON payload like Google, Twitter, Facebook
# Modern REST APIs now uses rfc9457 with a flattened payload.
# When the use_rfc_error object property is true, we use rfc9457 flattened error, this will produce something like:
# {
# error => 'not_found',
# status => 404,
# title => 'Not found!',
# detail => q{The requested URL was not found on this server. If you entered the URL manually please check your spelling and try again.},
# locale => 'en-US',
# type => 'https://api.example.com/problems/not-found',
# }
# otherwise, the legacy approach would be:
# {
# error =>
# {
# code => 404,
# message => q{The requested URL was not found on this server. If you entered the URL manually please check your spelling and try again.},
# },
# locale => 'en-US',
# }
# $self->reply( Apache2::Const::HTTP_OK, { message => "All is well" } );
if( scalar( @_ ) == 2 )
{
( $code, $ref ) = @_;
}
elsif( scalar( @_ ) == 1 &&
$self->_can( $_[0] => 'code' ) &&
$self->_can( $_[0] => 'message' ) )
{
my $ex = shift( @_ );
$code = $ex->code;
$ref =
{
message => $ex->message,
( $ex->can( 'public_message' ) ? ( public_message => $ex->public_message ) : () ),
( $ex->can( 'locale' ) ? ( locale => $ex->locale ) : () ),
};
}
# $self->reply({ code => Apache2::Const::HTTP_OK, message => "All is well" } );
elsif( ref( $_[0] ) eq 'HASH' )
{
$ref = shift( @_ );
$code = $ref->{code} if( length( $ref->{code} ) );
}
my $r = $self->apache_request;
my $req = $self->request;
my $resp = $self->response;
# Guardrails on inputs
if( !defined( $code ) || $code !~ /^[0-9]{3}$/ )
{
$resp->code( Apache2::Const::HTTP_INTERNAL_SERVER_ERROR );
$resp->rflush;
$resp->print( $self->json->utf8->encode({ error => 'An unexpected server error occured', code => 500 }) );
$self->error( "http code to be used '", ( $code // 'undef' ), "' is invalid. It should be only integers." );
return( Apache2::Const::HTTP_INTERNAL_SERVER_ERROR );
}
if( ref( $ref ) ne 'HASH' )
{
$resp->code( Apache2::Const::HTTP_INTERNAL_SERVER_ERROR );
$resp->rflush;
# $r->send_http_header;
$resp->print( $self->json->utf8->encode({ error => 'An unexpected server error occured', code => 500 }) );
$self->error( "Data provided to send is not a hash ref." );
return( Apache2::Const::HTTP_INTERNAL_SERVER_ERROR );
}
# Resolve whether this is an error
my $is_error = $resp->is_error( $code ) ? 1 : 0;
# NOTE: guess_preferred_locale() -> this is used to get he most appropriate locale if not defined already so we can, in turn, get the fallback description
my $guess_preferred_locale = sub
{
my $locale = shift( @_ );
if( !defined( $locale ) )
{
$locale = $req->preferred_language( Apache2::API::Status->supported_languages );
}
if( defined( $locale ) )
{
# Make sure we are dealing with unix style language code
$locale =~ tr/-/_/;
if( length( $locale ) == 2 )
{
$locale = Apache2::API::Status->convert_short_lang_to_long( $locale );
}
# We have something weird, like maybe eng?
elsif( $locale !~ /^[a-z]{2}_[A-Z]{2}$/ )
{
$locale = Apache2::API::Status->convert_short_lang_to_long( substr( $locale, 0, 2 ) );
}
}
return( $locale );
};
# NOTE: build_rfc_error() -> private subroutine to build the modern rfc9457 error payload
my $build_rfc_error = sub
{
my( $ref, $code, $msg ) = @_;
# By now, our property 'locale' has been dealt with, so we do not have to worry about it.
# It either exists or not
my $locale = exists( $ref->{locale} ) ? $ref->{locale} : undef;
# The property 'status' could exist, but be undefined, or even empty, so we check for that.
unless( exists( $ref->{status} ) &&
defined( $ref->{status} ) &&
length( $ref->{status} ) )
{
$ref->{status} = $code;
}
$ref->{status} = int( $ref->{status} ) if( $ref->{status} =~ /^\d+$/ );
# Title from caller or from HTTP status table (localized)
unless( exists( $ref->{title} ) &&
defined( $ref->{title} ) &&
length( $ref->{title} // '' ) )
{
if( exists( $ref->{error} ) &&
defined( $ref->{error} ) &&
ref( $ref->{error} ) eq 'HASH' &&
exists( $ref->{error}->{title} ) )
{
$ref->{title} = delete( $ref->{error}->{title} );
}
elsif( $locale )
{
$ref->{title} = Apache2::API::Status->status_message( $code => $locale );
}
else
{
$ref->{title} = Apache2::API::Status->status_message( $code );
}
}
# Detail/message precedence: explicit detail > message field > HTTP message
if( !defined( $ref->{detail} ) || $ref->{detail} eq '' )
{
if( exists( $ref->{details} ) && defined( $ref->{details} ) && $ref->{details} )
{
$r->log->warn( ref( $self ), ": warning only: you seem to have set the property 'details' in your error payload, but to build a rfc9457 error, you need to provide the property 'detail' instead." );
}
if( defined( $msg ) && ( !ref( $msg ) || $self->_can_overload( $msg => "''" ) ) )
{
$ref->{detail} = "$msg";
}
else
{
my $fallback = $locale
? $resp->get_http_message( $code, $locale )
: $resp->get_http_message( $code );
$ref->{detail} = $fallback // 'An error occurred';
}
}
# Clean up the 'error' property if it is a hash reference.
if( exists( $ref->{error} ) &&
defined( $ref->{error} ) &&
ref( $ref->{error} ) eq 'HASH' )
{
delete( $ref->{error}->{ $_ } ) for( qw( code status message title ) );
delete( $ref->{error} ) if( !scalar( keys( %{$ref->{error}} ) ) );
}
# Set the property 'error' (extension member): string problem code if empty hash/undef
if( !exists( $ref->{error} ) ||
!defined( $ref->{error} ) ||
( !ref( $ref->{error} ) && !length( $ref->{error} // '' ) ) ||
( ref( $ref->{error} ) eq 'HASH' && !scalar( keys( %{$ref->{error}} ) ) ) )
{
delete( $ref->{error} );
if( my $t = Apache2::API::Status->status_to_type( $code, '-' ) )
{
# extension member for app code
$ref->{error} = $t;
}
}
# Build 'type' URL if not provided.
unless( exists( $ref->{type} ) &&
defined( $ref->{type} ) &&
length( $ref->{type} // '' ) )
{
if( my $host = $req->http_host )
{
if( my $t = Apache2::API::Status->status_to_type( $code, '-' ) )
{
my $scheme = $req->is_secure ? 'https' : 'http';
$ref->{type} = "${scheme}://${host}/problems/${t}";
}
}
}
# Flatten legacy fields that do not belong.
# The rfc 9457 prefers the property 'detail'.
delete( $ref->{message} ) if( exists( $ref->{message} ) );
# The rfc 9457 prefers the property 'status'.
delete( $ref->{code} ) if( exists( $ref->{code} ) );
};
# NOTE: build_legacy_error() -> private subroutine to build the legacy error payload
my $build_legacy_error = sub
{
my( $ref, $code, $msg ) = @_;
# By now, our property 'locale' has been dealt with, so we do not have to worry about it.
# It either exists or not
my $locale = exists( $ref->{error}->{locale} ) ? $ref->{error}->{locale} : undef;
# We set the property 'error' to be an HASH if not set already.
$ref->{error} = {} unless( exists( $ref->{error} ) && ref( $ref->{error} ) eq 'HASH' );
# The property 'code' could exist, but be undefined, or even empty, so we check for that.
unless( exists( $ref->{error}->{code} ) &&
defined( $ref->{error}->{code} ) &&
length( $ref->{error}->{code} ) )
{
$ref->{error}->{code} = $code;
}
$ref->{error}->{code} = int( $ref->{error}->{code} ) if( $ref->{error}->{code} =~ /^\d+$/ );
# We try hard to get the value for the property 'message', but if $locale is undefined, it is impossible to find out the language that was used to formulate the response.
# So, ultimately, if we cannot find any value for the property 'message', we revert to guessing the HTTP caller's preferred language, which may, or may not be aligned with the content of other parts of the JSON response. Given that, in that s...
if( !exists( $ref->{error}->{message} ) ||
!defined( $ref->{error}->{message} ) ||
!length( $ref->{error}->{message} // '' ) )
{
if( defined( $msg ) &&
( !ref( $msg ) || $self->_can_overload( $msg => "''" ) ) )
{
$ref->{error}->{message} = "$msg";
}
else
{
foreach my $p ( qw( message detail details ) )
{
if( exists( $ref->{ $p } ) &&
defined( $ref->{ $p } ) &&
length( $ref->{ $p } ) )
{
$ref->{error}->{message} = delete( $ref->{ $p } );
last;
}
}
}
# Still nothing ? Get the fallback value using 'get_http_message' either using the $locale, if defined, or the HTTP caller's preferred language
if( !$ref->{error}->{message} )
{
$locale = $guess_preferred_locale->( $locale ) unless( defined( $locale ) );
my $fallback = $locale
? $resp->get_http_message( $code, $locale )
: $resp->get_http_message( $code );
$ref->{error}->{message} = $fallback // 'An error occurred';
}
}
# Build 'type' URL if not provided
unless( exists( $ref->{error}->{type} ) &&
defined( $ref->{error}->{type} ) &&
length( $ref->{error}->{type} // '' ) )
{
# The user has already set the 'type' property, so we use it, and move it to our 'error' hash
if( exists( $ref->{type} ) &&
defined( $ref->{type} ) &&
length( $ref->{type} ) )
{
$ref->{error}->{type} = delete( $ref->{type} );
}
elsif( my $host = $req->http_host )
{
if( my $t = Apache2::API::Status->status_to_type( $code ) )
{
(my $slug = $t) =~ tr/_/-/;
my $scheme = $req->is_secure ? 'https' : 'http';
$ref->{error}->{type} = "${scheme}://${host}/problems/${slug}";
}
}
elsif( my $t = Apache2::API::Status->status_to_type( $code ) )
{
$ref->{error}->{type} = $t;
}
}
# Collapse top-level duplicates
delete( $ref->{ $_ } ) for( qw( message code type error_description ) );
};
# NOTE: set_payload_locale() -> find out and set the 'locale' property.
my $set_payload_locale = sub
{
my( $ref, $msg ) = @_;
my $locale;
# From message object
# '$msg' might be undef, and the method _is_a knows how to handle it.
if( $self->_is_a( $msg => 'Text::PO::String' ) )
{
$locale = $msg->locale
}
# Check if the Content-Language has already been set.
elsif( my $l = $resp->headers->get( 'Content-Language' ) )
{
$locale = $l;
$locale =~ tr/_/-/;
}
if( !defined( $locale ) &&
exists( $ref->{error} ) &&
ref( $ref->{error} ) eq 'HASH' )
{
foreach my $p ( qw( locale lang ) )
{
if( exists( $ref->{error}->{ $p } ) &&
defined( $ref->{error}->{ $p } ) &&
length( $ref->{error}->{ $p } ) )
{
$locale = $ref->{error}->{ $p };
last;
}
}
}
if( !defined( $locale ) )
{
foreach my $p ( qw( locale lang ) )
{
if( exists( $ref->{ $p } ) &&
defined( $ref->{ $p } ) &&
length( $ref->{ $p } ) )
{
$locale = $ref->{ $p };
last;
}
}
}
# If we found a locale, we set it properly whether it is an error or success message.
if( defined( $locale ) )
{
if( $is_error )
{
if( $use_rfc_error )
{
$ref->{locale} = $locale;
if( exists( $ref->{error} ) &&
ref( $ref->{error} ) eq 'HASH' )
{
delete( $ref->{error}->{lang} );
delete( $ref->{error}->{locale} );
}
}
else
{
$ref->{error} //= {};
$ref->{error}->{locale} = $locale;
delete( $ref->{lang} );
delete( $ref->{locale} );
}
}
else
{
$ref->{locale} = $locale;
}
}
return( defined( $locale ) ? 1 : 0);
};
# '$msg' may possibly be a Text::PO::String, whose benefit is that it has the 'locale' method
my $msg;
if( exists( $ref->{success} ) && !exists( $ref->{message} ) )
{
$msg = $ref->{success};
}
# Maybe error is a string, or maybe it is already an error hash like { error => { message => '', code => '' } }
elsif( exists( $ref->{error} ) && $is_error )
{
# Caller gave us either a string or a hash under the property 'error'
if( ref( $ref->{error} ) eq 'HASH' )
{
$msg = $ref->{error}->{message};
if( !$code && exists( $ref->{error}->{code} ) )
{
$code = delete( $ref->{error}->{code} );
}
elsif( !$code && exists( $ref->{error}->{status} ) )
{
$code = delete( $ref->{error}->{status} );
}
# Remove those properties now
delete( $ref->{error}->{ $_ } ) for( qw( code status ) );
}
else
{
$msg = $ref->{error};
$ref->{error} = {} unless( $use_rfc_error );
}
$set_payload_locale->( $ref, $msg );
if( $use_rfc_error )
{
$build_rfc_error->( $ref, $code, $msg );
}
else
{
$build_legacy_error->( $ref, $code, $msg );
}
}
# Already flattened error or success response
elsif( exists( $ref->{message} ) )
{
$msg = $ref->{message};
# We format the message like in bailout, ie { error => { message => '', code => '' } }
if( $is_error )
{
if( $use_rfc_error )
{
$build_rfc_error->( $ref, $code, $msg );
}
else
{
$build_legacy_error->( $ref, $code, $msg );
}
}
# This is a success response
else
{
$ref->{success} = \1 unless( exists( $ref->{success} ) );
$ref->{code} //= $code;
$ref->{code} = int( $ref->{code} ) if( $ref->{code} =~ /^\d+$/ );
}
$set_payload_locale->( $ref, $msg );
}
# Or we just have a code to go on with
elsif( $is_error )
{
# No message, just a code => build minimal error body
if( $use_rfc_error )
{
$build_rfc_error->( $ref, $code, undef );
}
else
{
$build_legacy_error->( $ref, $code, undef );
}
}
# Success with no body details
else
{
$ref->{success} = \1 unless( exists( $ref->{success} ) );
$ref->{code} //= $code;
$ref->{code} = int( $ref->{code} ) if( $ref->{code} =~ /^\d+$/ );
}
# Without an Access-Control-Allow-Origin field, this would trigger an error on the web browser
# So we make sure it is there if not set already
unless( $resp->headers->get( 'Access-Control-Allow-Origin' ) )
{
$resp->headers->set( 'Access-Control-Allow-Origin' => '*' );
}
# As an api, make sure there is no caching by default unless the field has already been set.
unless( $resp->headers->get( 'Cache-Control' ) )
{
$resp->headers->set( 'Cache-Control' => 'private, no-cache, no-store, must-revalidate' );
}
# If we have a locale set, we use it
my $locale;
if( $is_error )
{
if( $use_rfc_error )
{
$locale = $ref->{locale} if( exists( $ref->{locale} ) );
}
else
{
$locale = $ref->{error}->{locale} if( exists( $ref->{error} ) && ref( $ref->{error} ) eq 'HASH' && exists( $ref->{error}->{locale} ) );
}
}
# Success response
else
{
$locale = $ref->{locale} if( exists( $ref->{locale} ) );
}
if( $locale )
{
# Set the content language for this payload unless the user has already set it.
unless( $resp->headers->get( 'Content-Language' ) )
{
# en_GB -> en-GB
( my $hdr_locale = $locale ) =~ tr/_/-/;
$resp->headers->set( 'Content-Language' => $hdr_locale );
}
$resp->headers->merge( 'Vary' => 'Accept-Language' );
}
# Choose Content-Type
# If we use new modern error, then we set application/problem+json in line with rfc7807
my $ctype = ( $is_error && $use_rfc_error )
? 'application/problem+json; charset=utf-8'
: 'application/json; charset=utf-8';
$resp->content_type( $ctype );
# $r->status( $code );
$resp->code( $code );
if( defined( $msg ) && $ctype !~ m{^application/(?:json|problem\+json)}i )
{
$resp->custom_response( $code, $msg );
}
else
{
$resp->custom_response( $code, '' );
#$r->status( $code );
}
if( exists( $ref->{cleanup} ) &&
defined( $ref->{cleanup} ) &&
ref( $ref->{cleanup} ) eq 'CODE' )
{
my $cleanup = delete( $ref->{cleanup} );
# See <https://perl.apache.org/docs/2.0/user/handlers/http.html#PerlCleanupHandler>
$r->pool->cleanup_register( $cleanup, $self );
}
# Our print() will possibly change the HTTP headers, so we do not flush now just yet.
my $json = $self->json->utf8->relaxed(0)->allow_blessed->convert_blessed->encode( $ref );
# Before we use this, we have to make sure all Apache module that deal with content encoding are de-activated because they would interfere
if( !$self->print( $json ) )
{
return( Apache2::Const::HTTP_INTERNAL_SERVER_ERROR );
}
return( $code );
}
# Special reply for Server-Sent Event that need to close the connection if there was an error
sub reply_sse
{
my $self = shift( @_ );
my $code = $self->reply( @_ );
$code //= 500;
if( Apache2::API::Status->is_error( $code ) )
{
my $req = $self->request;
$req->request->pool->cleanup_register(sub
{
$req->close;
});
}
return( $code );
}
sub request { return( shift->_set_get_object( 'request', 'Apache2::API::Request', @_ ) ); }
( run in 1.119 second using v1.01-cache-2.11-cpan-ceb78f64989 )