Apache2-API

 view release on metacpan or  search on metacpan

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

    use vars qw( $VERSION $DEBUG @EXPORT $USE_RFC_ERROR );
    use version;
    use Encode ();
    # use Apache2::Const qw( :common :http );
    use Apache2::Const -compile => qw( :cmd_how :common :config :conn_keepalive :context :filter_type :http :input_mode :log :methods :mpmq :options :override :platform :remotehost :satisfy :types :proxy );
    use APR::Const -compile => qw( :common :error :fopen :filepath :fprot :filetype :finfo :flock :hook :limit :lockmech :poll :read_type :shutdown_how :socket :status :table :uri );
    use Apache2::RequestRec ();
    use Apache2::RequestIO ();
    use Apache2::ServerUtil ();
    use Apache2::RequestUtil ();
    use Apache2::Response ();
    use Apache2::Log ();
    use Apache2::API::Request;
    use Apache2::API::Response;
    use Apache2::API::Status;
    use APR::Base64 ();
    use APR::Request ();
    use APR::UUID ();
    use Exporter ();
    use JSON ();
    use Scalar::Util ();
    our @EXPORT = qw( apr1_md5 );
    $DEBUG   = 0;
    $VERSION = 'v0.5.3';
};

use strict;
use warnings;

sub import
{
    my( $this, @arguments ) = @_ ;
    my $class = CORE::caller();
    # my $code = qq{package ${class}; use Apache2::Const -compile => qw( @arguments );};
    # print( "Evaluating -> $code\n" );
    # eval( $code );
    # print( "\$@ -> $@\n" );

    # local $Exporter::ExportLevel = 1;
    # Apache2::Const->import( '-compile' => @arguments );
    # my @argv = grep( !/^\:http/, @arguments );
    # Apache2::Const->compile( '-compile' => @argv );
    # Apache2::Const->compile( $class => qw( AUTH_REQUIRED ) );

    Apache2::Const->compile( $class => @arguments );
    Exporter::export_to_level( $this, 1, @EXPORT );
}

sub init
{
    my $self = shift( @_ );
    my $r;
    $r = shift( @_ ) if( @_ % 2 );
    # my $r = shift( @_ ) || Apache2::RequestUtil->request;
    $self->{request}                = undef unless( $self->{request} );
    $self->{response}               = undef unless( $self->{response} );
    $self->{apache_request}         = $r unless( $self->{apache_request} );
    # 200Kb
    $self->{compression_threshold}  = 204800 unless( length( $self->{compression_threshold} ) );
    $self->{use_rfc_error}          = $USE_RFC_ERROR unless( length( $self->{use_rfc_error} ) );
    $self->SUPER::init( @_ ) || return( $self->pass_error );
    unless( $r = $self->apache_request )
    {
        $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 ) )
        {

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

}

sub decode_url
{
    my $self = shift( @_ );
    return( APR::Request::decode( shift( @_ ) ) );
}

sub decode_utf8
{
    my $self = shift( @_ );
    my $v = shift( @_ );
    my $rv = eval
    {
        ## utf8 is more lax than the strict standard of utf-8; see Encode man page
        Encode::decode( 'utf8', $v, Encode::FB_CROAK );
    };
    if( $@ )
    {
        $self->error( "Error while decoding text: $@" );
        return( $v );
    }
    return( $rv );
}

# https://perl.apache.org/docs/2.0/api/APR/Base64.html#toc_C_encode_
# sub encode_base64 { return( APR::Base64::encode( @_ ) ); }
sub encode_base64
{
    my $self = shift( @_ );
    my $data = shift( @_ );
    return( $self->error( "No valid to base64 encode was provided." ) ) if( !length( $data ) );
    # try-catch
    local $@;
    my $rv = eval
    {
        return( APR::Base64::encode( $data ) );
    };
    if( $@ )
    {
        return( $self->error( "An error occurred while trying to base64 encode data: $@" ) );
    }
    return( $rv );
}

sub encode_json
{
    my $self = shift( @_ );
    my $hash = shift( @_ ) || return( $self->error( "No perl hash reference was provided to encode." ) );
    return( $self->error( "Hash provided ($hash) is not a hash reference." ) ) if( !$self->_is_hash( $hash ) );
    my $json = $self->json->allow_nonref->allow_blessed->convert_blessed->relaxed;
    my $data;
    # try-catch
    local $@;
    eval
    {
        $data = $json->encode( $hash );
    };
    if( $@ )
    {
        return( $self->error( "An error occurred while trying to encode perl data: $@\nPerl data are: ", sub{ $self->SUPER::dump( $hash ) } ) );
    }
    return( $data );
}

sub encode_url
{
    my $self = shift( @_ );
    return( APR::Request::encode( shift( @_ ) ) );
}

sub encode_utf8
{
    my $self = shift( @_ );
    my $v = shift( @_ );
    my $rv = eval
    {
        ## utf8 is more lax than the strict standard of utf-8; see Encode man page
        Encode::encode( 'utf8', $v, Encode::FB_CROAK );
    };
    if( $@ )
    {
        $self->error( "Error while encoding text: $@" );
        return( $v );
    }
    return( $rv );
}

# <https://perl.apache.org/docs/2.0/api/APR/UUID.html>
sub generate_uuid
{
    my $self = shift( @_ );
    # try-catch
    local $@;
    my $rv = eval
    {
        return( APR::UUID->new->format );
    };
    if( $@ )
    {
        return( $self->error( "An error occurred while trying to generate an uuid using APR::UUID package: $@" ) );
    }
    return( $rv );
}

# rfc 6750 <https://tools.ietf.org/html/rfc6750>
sub get_auth_bearer
{
    my $self = shift( @_ );
    my $bearer = $self->request->authorization;
    # Found a bearer
    if( $bearer )
    {
        # https://jwt.io/introduction/
        # https://tools.ietf.org/html/rfc7519
        # if( $bearer =~ /^Bearer[[:blank:]]+([a-zA-Z0-9][a-zA-Z0-9\-\_\~\+\/\=]+(?:\.[a-zA-Z0-9\_][a-zA-Z0-9\-\_\~\+\/\=]+){2,4})$/i )
        if( $bearer =~ /^Bearer[[:blank:]]+([a-zA-Z0-9][a-zA-Z0-9\-\_\~\+\/\=]+(?:\.[a-zA-Z0-9\_][a-zA-Z0-9\-\_\~\+\/\=]+)*)$/i )
        {
            my $token = $1;
            return( $token );
        }

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

    $txt = sprintf( "$txt called from %s in package %s in file %s at line %d\n%s\n",  $frame2->subroutine, $frame->package, $frame->filename, $frame->line, $trace->as_string );
    return( $r->warn( $txt ) ) if( $r );
    return( CORE::warn( $txt ) );
}

sub _try
{
    my $self = shift( @_ );
    my $pack = shift( @_ ) || return( $self->error( "No Apache package name was provided to call method" ) );
    my $meth = shift( @_ ) || return( $self->error( "No method name was provided to try!" ) );
    my $r = Apache2::RequestUtil->request;
    # $r->log_error( "Apache2::API::_try to call method \"$meth\" in package \"$pack\"." );
    # try-catch
    local $@;
    my $rv = eval
    {
        return( $self->$pack->$meth ) if( !scalar( @_ ) );
        return( $self->$pack->$meth( @_ ) );
    };
    if( $@ )
    {
        return( $self->error( "An error occurred while trying to call Apache ", ucfirst( $pack ), " method \"$meth\": $@" ) );
    }
    return( $rv );
}

# NOTE: sub FREEZE is inherited

sub STORABLE_freeze { CORE::return( CORE::shift->FREEZE( @_ ) ); }

sub STORABLE_thaw { CORE::return( CORE::shift->THAW( @_ ) ); }

# NOTE: sub THAW is inherited

# NOTE: Apache2::API::Password
package Apache2::API::Password;
use parent qw( Module::Generic );
use strict;
use warnings;
use vars qw( $VERSION $APR1_RE $BCRYPT_RE $SHA_RE );
# Compile the regular expression once
our $APR1_RE   = qr/\$apr1\$(?<salt>[.\/0-9A-Za-z]{1,8})\$[.\/0-9A-Za-z]{22}/;
our $BCRYPT_RE = qr/\$2[aby]\$(?<bcrypt_cost>\d{2})\$(?<salt>[A-Za-z0-9.\/]{22})[A-Za-z0-9.\/]{31}/;
our $SHA_RE    = qr/\$(?<sha_size>[56])\$(?:rounds=(?<rounds>\d+)\$)?(?<salt>[A-Za-z0-9.\/]{1,16})\$[A-Za-z0-9.\/]+/;
our $VERSION   = 'v0.1.1';

sub init
{
    my $self = shift( @_ );
    my $pwd  = shift( @_ );
    return( $self->error( "No password was provided." ) ) if( !defined( $pwd ) );
    $self->{create}        = 0     if( !exists( $self->{create} ) );
    # md5 | bcrypt | sha256 | sha512
    $self->{algo}          = 'md5' if( !exists( $self->{algo} ) );
    # 04..31
    $self->{bcrypt_cost}   = 12    if( !exists( $self->{bcrypt_cost} ) );
    # undef => default (5000)
    $self->{sha_rounds}    = undef if( !exists( $self->{sha_rounds} ) );
    # By default, like Apache does, we use Apache md5 algorithm
    # Other possibilities are bcrypt (Blowfish)
    $self->SUPER::init( @_ ) ||
        return( $self->pass_error );
    if( $self->{create} )
    {
        my $hash = $self->make( $pwd ) ||
            return( $self->pass_error );
        $self->hash( $hash );
    }
    # Existing hash path: validate by known prefixes, also extract salt into ->salt
    elsif( $pwd =~ /\A$APR1_RE\z/ ||
           $pwd =~ /\A$BCRYPT_RE\z/ ||
           $pwd =~ /\A$SHA_RE\z/ )
    {
        $self->hash( $pwd );
    }
    else
    {
        return( $self->error(
            "Value provided is not a recognized hash (APR1/bcrypt/SHA-crypt). " .
            "If you want to create one from clear text, use the 'create' option."
        ) );
    }
    return( $self );
}

sub algo { return( shift->_set_get_enum({
    field => 'algo',
    allowed => [qw( md5 bcrypt sha256 sha512 )],
}, @_ ) ); }

sub bcrypt_cost { return( shift->_set_get_scalar({
    field => 'bcrypt_cost',
    check => sub
    {
        my( $self, $v ) = @_;
        return(1) unless( defined( $v ) );
        unless( $v =~ /^\d+$/ && 
                $v >= 4 &&
                $v <= 31 )
        {
            return( $self->error( "bcrypt_cost must be between 4 and 31" ) );
        }
        return(1);
    },
}, @_ ) ); }

sub create { return( shift->_set_get_boolean( 'create', @_ ) ); }

sub hash { return( shift->_set_get_scalar({
    field => 'hash',
    callbacks =>
    {
        set => sub
        {
            my( $self, $v ) = @_;
            if( $v =~ /\A$APR1_RE\z/ )
            {
                $self->{salt} = $+{salt}
            }
            elsif( $v =~ /\A$BCRYPT_RE\z/ )
            {