Apache2-API

 view release on metacpan or  search on metacpan

lib/Apache2/API.pm  view on Meta::CPAN

# This gives a chance to return a localised version of our string to the user
sub gettext { return( $_[1] ); }

sub header_datetime
{
    my $self = shift( @_ );
    my $dt;
    if( @_ )
    {
        return( $self->error( "Date time provided (", ( $_[0] // 'undef' ), ") is not an object." ) ) if( !Scalar::Util::blessed( $_[0] ) );
        return( $self->error( "Object provided (", ref( $_[0] ), ") is not a DateTime object." ) ) if( !$_[0]->isa( 'DateTime' ) );
        $dt = shift( @_ );
    }
    $dt = DateTime->now if( !defined( $dt ) );
    my $fmt = Apache2::API::DateTime->new;
    $dt->set_formatter( $fmt );
    return( $dt );
}

sub htpasswd
{
    my $self = shift( @_ );
    my $rv = Apache2::API::Password->new( @_ );
    if( !defined( $rv ) && Apache2::API::Password->error )
    {
        return( $self->pass_error( Apache2::API::Password->error ) );
    }
    return( $rv );
}

sub is_perl_option_enabled { return( shift->_try( 'request', 'is_perl_option_enabled', @_ ) ); }

# We return a new object each time, because if we cached it, some routine might set the utf8 bit flagged on while some other would not want it
sub json
{
    my $self = shift( @_ );
    my $opts = $self->_get_args_as_hash( @_ );
    my $j = JSON->new;
    my $equi =
    {
        ordered => 'canonical',
        sorted => 'canonical',
        sort => 'canonical',
    };

    foreach my $opt ( keys( %$opts ) )
    {
        my $ref;
        $ref = $j->can( exists( $equi->{ $opt } ) ? $equi->{ $opt } : $opt ) || do
        {
            warn( "Unknown JSON option '${opt}'\n" ) if( $self->_warnings_is_enabled );
            next;
        };
        $ref->( $j, $opts->{ $opt } );
    }
    return( $j );
}

sub lang { return( shift->_set_get_scalar( 'lang', @_ ) ); }

sub lang_unix
{
    my $self = shift( @_ );
    my $lang = $self->{lang};
    $lang =~ tr/-/_/;
    return( $lang );
}

sub lang_web
{
    my $self = shift( @_ );
    my $lang = $self->{lang};
    $lang =~ tr/_/-/;
    return( $lang );
}

# Would return a Apache2::Log::Request
sub log { return( shift->_try( 'apache_request', 'log', @_ ) ); }

sub log_error { return( shift->_try( 'apache_request', 'log_error', @_ ) ); }

sub print
{
    my $self = shift( @_ );
    my $opts = {};
    if( scalar( @_ ) == 1 && ref( $_[0] ) )
    {
        $opts = shift( @_ );
    }
    else
    {
        $opts->{data} = join( '', @_ );
    }
    return( $self->error( "No data was provided to print out." ) ) if( !CORE::length( $opts->{data} ) );
    my $r = $self->apache_request;
    my $json = $opts->{data};
    my $bytes = 0;
    # Before we use this, we have to make sure all Apache module that deal with content encoding are de-activated because they would interfere
    my $threshold = $self->compression_threshold || 0;
    # rfc1952
    # https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Accept-Encoding
    my $z;
    if( CORE::length( $json ) > $threshold && 
        $self->request->accept_encoding =~ /\bgzip\b/i && 
        $self->_load_class( 'IO::Compress::Gzip' ) && 
        ( $z = IO::Compress::Gzip->new( '-', Minimal => 1 ) ) )
    {
        #require Compress::Zlib;
        #$r->print( Compress::Zlib::memGzip( $json ) );
        # $r->content_encoding( 'gzip' );
        $self->response->content_encoding( 'gzip' );
        $self->response->headers->set( 'Content-Encoding' => 'gzip' );
        # Why Vary? https://blog.stackpath.com/accept-encoding-vary-important/
        # We use merge, because another value may already be set
        $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 =~ /\bbzip2\b/i &&

lib/Apache2/API.pm  view on Meta::CPAN

    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." );
            }

lib/Apache2/API.pm  view on Meta::CPAN

=encoding utf-8

=head1 NAME

Apache2::API - Apache2 API Framework

=head1 SYNOPSIS

    use Apache2::API
    # To import in your namespace
    # use Apache2::API qw( :common :http );

    # $r is an Apache2::RequestRec object that you can get from within an handler or 
    # with Apache2::RequestUtil->request
    my $api = Apache2::API->new( $r, compression_threshold => 204800 ) ||
        die( Apache2::API->error );
    # or:
    my $api = Apache2::API->new( apache_request => $r, compression_threshold => 204800 ) ||
        die( Apache2::API->error );

    # or even inside your mod_perl script/cgi:
    #!/usr/bin/perl
    use strict;
    use warnings;
    use Apache2::API;

    my $r = shift( @_ );
    my $api = Apache2::API->new( $r );
    # for example:
    return( $api->reply( Apache2::Const::HTTP_OK => { message => "Hello world" } ) );

    my $r = $api->apache_request;
    return( $api->bailout({
        message => "Oops",
        code => Apache2::Const::BAD_REQUEST,
        public_message => "An unexpected error occurred.",
    }) );
    # or
    return( $api->bailout( @some_reasons ) );

    # 100kb
    $api->compression_threshold(102400);
    my $decoded = $api->decode_base64( $b64_string );
    my $ref = $api->decode_json( $json_data );
    my $decoded = $api->decode_url;
    my $perl_utf8 = $api->decode_utf8( $data );
    my $b64_string = $api->encode_base64( $data );
    my $json_data = $api->encode_json( $ref );
    my $encoded = $api->encode_url( $uri );
    my $utf8 = $api->encode_utf8( $data );
    my $uuid = $api->generate_uuid;
    my $auth = $api->get_auth_bearer;
    my $handlers = $api->get_handlers;
    my $dt = $api->header_datetime( $http_datetime );
    my $bool = $api->is_perl_option_enabled;
    # JSON object
    my $json = $api->json( pretty => 1, sorted => 1, relaxed => 1 );
    my $lang = $api->lang( 'en_GB' );
    # en_GB
    my $lang = $api->lang_unix;
    # en-GB
    my $lang = $api->lang_web;
    $api->log_error( "Oops" );
    $api->print( @some_data );
    $api->push_handlers( $name => $code_reference );
    return( $api->reply( Apache2::Const::HTTP_OK => {
        message => "All good!",
        # arbitrary property
        client_id => "efe4bcf3-730c-4cb2-99df-25d4027ec404",
        # special property
        cleanup => sub
        {
            # Some code here to be executed after the reply is sent out to the client.
        }
    }) );
    # Apache2::API::Request
    my $req = $api->request;
    # Apache2::API::Response
    my $req = $api->response;
    my $server = $api->server;
    my $version = $api->server_version;
    $api->set_handlers( $name => $code_reference );
    $api->warn( @some_warnings );

    my $hash = apr1_md5( $clear_password );
    my $hash = apr1_md5( $clear_password, $salt );
    my $ht = $api->htpasswd( $clear_password );
    my $ht = $api->htpasswd( $clear_password, salt => $salt );
    my $hash = $ht->hash;
    say "Does our password match ? ", $ht->matches( $user_clear_password ) ? "yes" : "not";

=head1 VERSION

    v0.5.3

=head1 DESCRIPTION

This module provides a comprehensive, powerful, yet simple framework to access L<Apache mod_perl's API|https://perl.apache.org/docs/2.0/api/> and documented appropriately.

Apache mod_perl is an awesome framework, but quite complexe with a steep learning curve and methods all over the place. So much so that L<they have developed a module dedicated to find appropriate methods|https://perl.apache.org/docs/2.0/user/coding/...

=head1 METHODS

=head2 new

    my $api = Apache2::API->new( $r, $hash_ref_of_options );
    # or
    my $api = Apache2::API->new( apache_request => $r, compression_threshold => 102400 );

This initiates the package and takes an L<Apache2::RequestRec> object and an hash or hash reference of parameters, or only an hash or hash reference of parameters:

=over 4

=item * C<apache_request>

See L</apache_request>

=item * C<compression_threshold>

See L</compression_threshold>

lib/Apache2/API.pm  view on Meta::CPAN

=head2 get_auth_bearer

Checks whether an C<Authorization> HTTP header was provided, and get the Bearer value.

If no header was found, it returns an empty string.

If an error occurs, it will return undef and set an exception that can be accessed with the B<error> method.

=head2 get_handlers

Returns a reference to a list of handlers enabled for a given phase.

    $handlers_list = $res->get_handlers( $hook_name );

A list of handlers configured to run at the child_exit phase:

    @handlers = @{ $res->get_handlers( 'PerlChildExitHandler' ) || []};

=head2 gettext( 'string id' )

Get the localised version of the string passed as an argument.

This is supposed to be superseded by the package inheriting from L<Apache2::API>, if any.

=head2 header_datetime( DateTime object )

Given a L<DateTime> object, this sets it to GMT time zone and set the proper formatter (L<Apache2::API::DateTime>) so that the stringification is compliant with HTTP headers standard.

=head2 htpasswd

    my $ht = $api->htpasswd( $clear_password, create => 1 );
    my $ht = $api->htpasswd( $clear_password, create => 1, salt => $salt );
    my $ht = $api->htpasswd( $md5_password );
    my $bool = $ht->matches( $user_input_password );

This instantiates a new L<Apache2::API::Password> object by providing its constructor whatever arguments was received.

It returns a new L<Apache2::API::Password> object, or, upon error, C<undef> in scalar context, or an empty list in list context.

=head2 is_perl_option_enabled

Checks if perl option is enabled in the Virtual Host and returns a boolean value

=head2 json

Returns a JSON object.

You can provide an optional hash or hash reference of properties to enable or disable:

    my $J = $api->json( pretty => 1, relaxed => 1 );

Each property corresponds to one that is supported by L<JSON>

It also supports C<ordered>, C<order> and C<sort> as an alias to C<canonical>

=head2 lang( $string )

Set or get the language for the API. This would typically be the HTTP preferred language.

=head2 lang_unix( $string )

Given a language, this returns a language code formatted the unix way, ie en-GB would become en_GB

=head2 lang_web( $string )

Given a language, this returns a language code formatted the web way, ie en_GB would become en-GB

=head2 log

    $api->log->emerg( "Urgent message." );
    $api->log->alert( "Alert!" );
    $api->log->crit( "Critical message." );
    $api->log->error( "Error message." );
    $api->log->warn( "Warning..." );
    $api->log->notice( "You should know." );
    $api->log->info( "This is for your information." );
    $api->log->debug( "This is debugging message." );

Returns a L<Apache2::Log::Request> object.

=head2 log_error( $string )

Given a string, this will log the data into the error log.

When log_error is accessed with the L<Apache2::RequestRec> the error gets logged into the Virtual Host log, but when log_error gets accessed via the L<Apache2::ServerUtil> object, the error get logged into the Apache main error log.

=head2 print( @list )

print out the list of strings and returns the number of bytes sent.

The data will possibly be compressed if the HTTP client L<acceptable encoding|HTTPs://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Accept-Encoding> and if the data exceeds the value set in L</compression_threshold>

It will gzip it if the HTTP client acceptable encoding is C<gzip> and if L<IO::Compress::Gzip> is installed.

It will bzip it if the HTTP client acceptable encoding is C<bzip2> and if L<IO::Compress::Bzip2> is installed.

It will deflate if if the HTTP client acceptable encoding is C<deflate> and L<IO::Compress::Deflate> is installed.

If none of the above is possible, the data will be returned uncompressed.

Note that the HTTP header C<Vary> will be added the C<Accept-Encoding> value.

=head2 push_handlers

Returns the values from L<Apache2::Server/push_handlers> by passing it whatever arguments were provided.

=head2 reply

This takes an HTTP code and a message, or an exception object such as L<Module::Generic::Exception> or any other object that supports the C<code> and C<message> method, or just a hash reference, B<reply> will find out if the code provided is an error...

    { "error": { "code": 400, "message": "Some error" } }

It will json encode the returned data and print it out back to the client after setting the HTTP returned code.

If a C<cleanup> hash property is provided with a callback code reference as a value, it will be set as a cleanup callback by calling C<< $r->pool->cleanup_register >>. See L<https://perl.apache.org/docs/2.0/user/handlers/http.html#PerlCleanupHandler>

The L<Apache2::API> object will be passed as the first and only argument to the callback routine.

=head2 reply_sse

Special reply for Server-Sent Event that need to close the connection if there was an error.