view release on metacpan or  search on metacpan

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

# $ok = $s->set_handlers($hook_name => [\&handler, \&handler2]);
# $ok = $s->set_handlers($hook_name => []);
# $ok = $s->set_handlers($hook_name => undef);
# https://perl.apache.org/docs/2.0/api/Apache2/ServerUtil.html#C_set_handlers_
sub set_handlers { return( shift->_try( 'server', 'set_handlers', @_ ) ); }

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

sub warn
{
    my $self = shift( @_ );
    my $txt = join( '', map( ref( $_ ) eq 'CODE' ? $_->() : $_, @_ ) );
    my( $pkg, $file, $line, @otherInfo ) = caller;
    my $sub = ( caller( 1 ) )[3];
    my $sub2 = substr( $sub, rindex( $sub, '::' ) + 2 );
    my $trace = $self->_get_stack_trace();
    my $frame = $trace->next_frame;
    my $frame2 = $trace->next_frame;
    my $r = $self->apache_request;
    $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);
    },

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

    }

    # 3) tiny bcrypt-base64 encoder (./A–Z a–z 0–9), 16 bytes -> 22 chars
    my $alpha = './ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789';
    my @b = unpack( 'C*', $raw );
    my $out = '';
    for( my $i = 0; $i < @b; $i += 3 )
    {
        my $c1 = $b[$i];
        my $c2 = ( $i + 1 < @b ) ? $b[ $i + 1 ] : 0;
        my $c3 = ( $i + 2 < @b ) ? $b[ $i + 2 ] : 0;
        my $w  = ( $c1 << 16 ) | ( $c2 << 8 ) | $c3;
        # emit 4 chars, least-significant 6 bits first
        for( 1..4 )
        {
            $out .= substr( $alpha, $w & 0x3f, 1 );
            $w >>= 6;
        }
    }
    # bcrypt wants exactly 22 chars for 16-byte input
    return( substr( $out, 0, 22 ) );
}

sub _make_sha_crypt
{
    my $self = shift( @_ );
    # $which = 5 or 6
    my( $which, $passwd, $salt ) = @_;
    if( !defined( $which ) || !length( $which // '' ) )
    {
        return( $self->error( "No SHA version was provided. This should be 5 for 256, and 6 for 512." ) );
    }
    elsif( $which !~ /^\d$/ )
    {
        return( $self->error( "SHA version provided is not an integer." ) );
    }
    elsif( $which != 5 && $which != 6 )
    {
        return( $self->error( "Invalid SHA version provided. It should be either 5 or 6." ) );
    }
    # undef => default 5000
    my $rounds = $self->sha_rounds;

    $salt //= $self->_make_salt(16);
    if( $salt =~ m,[^./0-9A-Za-z], )
    {
        return( $self->error( "Salt value provided contains illegal characters." ) );
    }
    $salt = substr( $salt, 0, 16 );

    my $setting = defined( $rounds )
        ? sprintf( '$%d$rounds=%d$%s$', $which, $rounds, $salt )
        : sprintf( '$%d$%s$',           $which,          $salt );

    local $@;
    # try-catch
    my $hash = eval
    {
        crypt( $passwd, $setting );
    };
    if( !$@ && defined( $hash ) && $hash =~ /^\$[56]\$/ )
    {
        return( $hash );
    }

    my $crypt_error = $@;
    my $sha_version = ( $which == 5 ? 256 : 512 );

    # Fallback: Crypt::Passwd::XS
    if( $self->_load_class( 'Crypt::Passwd::XS' ) )
    {
        $hash = eval
        {
            # XS exposes a `crypt`-like function:
            Crypt::Passwd::XS::crypt( $passwd, $setting );
        };
        if( $@ )
        {
            return( $self->error( "Error generating a SHA-${sha_version} hash using Crypt::Passwd::XS: $@" ) );
        }
        elsif( defined( $hash ) && $hash =~ /^\$[56]\$/ )
        {
            return( $hash );
        }
        else
        {
            return( $self->error( "Unable to generate a SHA-${sha_version} hash using Crypt::Passwd::XS." ) );
        }
    }
    elsif( $crypt_error )
    {
        return( $self->error( "Error generating SHA-${sha_version} hash, and alternative modules (Crypt::Passwd::XS) are not installed: $@" ) );
    }
    else
    {
        return( $self->error( "System crypt() does not support SHA-${sha_version}, and alternative modules (Crypt::Passwd::XS) are not installed" ) );
    }
}

sub _to64
{
    my $self = shift( @_ );
    my( $v, $n, $itoa64 ) = @_;
    my $s = '';
    while( $n-- > 0 )
    {
        $s .= substr( $itoa64, $v & 0x3f, 1 );
        $v >>= 6;
    }
    return( $s );
}

1;
# NOTE: POD
__END__

=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;