view release on metacpan or  search on metacpan

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

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

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

    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/ )
            {
                $self->{salt} = $+{salt};
                $self->{bcrypt_cost} = $+{bcrypt_cost};
            }
            elsif( $v =~ /\A$SHA_RE\z/ )
            {
                $self->{salt} = $+{salt};
                $self->{sha_rounds} = $+{rounds} if( defined( $+{rounds} ) );
            }