Apache2-API

 view release on metacpan or  search on metacpan

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

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

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

    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 )
    {

lib/Apache2/API/Password.pod  view on Meta::CPAN

=head2 make_bcrypt

    my $hash = $ht->make_bcrypt( $clear_password, $salt );

Generates a bcrypt hash (C<$2y$<cost>$<salt-and-hash>). Salt is 22 chars, default random. Uses C<bcrypt_cost>.

=head2 make_sha256

    my $hash = $ht->make_sha256( $clear_password, $salt );

Generates a SHA-256 crypt hash (C<$5$[rounds=<n>$]<salt>$<hash>). Salt is 1–16 chars, default random. Uses C<sha_rounds>.

=head2 make_sha512

    my $hash = $ht->make_sha512( $clear_password, $salt );

Generates a SHA-512 crypt hash (C<$6$[rounds=<n>$]<salt>$<hash>). Salt is 1–16 chars, default random. Uses C<sha_rounds>.

=head2 matches

    my $ok = $ht->matches( $user_input_password );

Compute a fresh hash using the instance salt and compare with the stored L<hash|/hash>.

Returns true if the cleartext password matches.

=head1 EXAMPLES

t/06.apr1.t  view on Meta::CPAN

my $have_sha256_crypt = _crypt_supports( qr/^\$5\$/, _sha256_setting( $sha_rounds, $salt16 ) );
my $have_sha512_crypt = _crypt_supports( qr/^\$6\$/, _sha512_setting( $sha_rounds, $salt16 ) );
my $have_sha_fallback = _have_module( 'Crypt::Passwd::XS' );

subtest 'format & alphabet' => sub
{
    # random salt
    my $ht = $api->htpasswd( 'secret', create => 1 );
    my $h = $ht->hash;
    like( $h, qr/\A\$apr1\$[.\/0-9A-Za-z]{1,8}\$[.\/0-9A-Za-z]{22}\z/, 'hash format looks right' );

    my( $salt, $body ) = $h =~ m/\A\$apr1\$([.\/0-9A-Za-z]{1,8})\$([.\/0-9A-Za-z]{22})\z/;
    ok( length( $salt ) >= 1 && length( $salt ) <= 8, 'salt length within [1..8]' );
    ok( length( $body ) == 22, 'encoded body is 22 chars' );

    my $alphabet = qr/[.\/0-9A-Za-z]/;
    ok( ( $salt =~ /\A$alphabet+\z/ ), 'salt chars in alphabet' );
    ok( ( $body =~ /\A$alphabet+\z/ ), 'body chars in alphabet' );
};

subtest 'determinism for fixed salt' => sub
{
    my $h1 = apr1_md5( 'secret', 'hfT7jp2q' );
    my $h2 = apr1_md5( 'secret', 'hfT7jp2q' );
    is( $h1, $h2, 'same password+salt => same hash' );
    like( $h1, qr/\A\$apr1\$hfT7jp2q\$[.\/0-9A-Za-z]{22}\z/, 'hash contains given salt' );
};

subtest 'verify positive/negative' => sub
{
    my $h = apr1_md5( 'opensesame', 'AB12.Cd/' );
    ok( verify_apr1( 'opensesame', $h ), 'verify succeeds on correct password' );
    ok( !verify_apr1( 'wrong',     $h ), 'verify fails on wrong password' );

    ok( !verify_apr1( 'opensesame', '$apr1$bad*salt$xxxxxxxxxxxxxxxxxxxxxx' ), 'rejects invalid salt chars' );
    ok( !verify_apr1( 'opensesame', '$apr1$short$too_short' ),                 'rejects invalid body length' );

t/06.apr1.t  view on Meta::CPAN

        unless( $have_any )
        {
            skip( 'No bcrypt support via crypt() and no fallback modules installed', 1 );
        }

        my $pw = "correct horse battery staple";
        my $ht = $api->htpasswd( $pw, create => 1, algo => 'bcrypt', bcrypt_cost => $bcrypt_cost );
        ok( $ht, 'constructed bcrypt object' );

        my $hash = $ht->hash;
        like( $hash, qr/^\$2[aby]\$\d{2}\$[A-Za-z0-9.\/]{22}[A-Za-z0-9.\/]{31}\z/, 'bcrypt hash format' );

        ok( $ht->matches( $pw ), 'matches() true for bcrypt' );

        # Re-wrap existing hash and verify again
        my $ht2 = $api->htpasswd( $hash );
        ok( $ht2->matches( $pw ), 're-wrapped bcrypt hash verifies' );
    };
};

subtest 'sha256 ($5$) make + matches' => sub

t/06.apr1.t  view on Meta::CPAN

        unless( $have_any )
        {
            skip( 'No SHA-256 crypt support and no Crypt::Passwd::XS', 1 );
        }

        my $pw = "f0utr1qu&3t";
        my $ht = $api->htpasswd( $pw, create => 1, algo => 'sha256', sha_rounds => $sha_rounds );
        ok( $ht, 'constructed sha256 object' );

        my $hash = $ht->hash;
        like( $hash, qr/^\$5\$(?:rounds=\d+\$)?[A-Za-z0-9.\/]{1,16}\$[A-Za-z0-9.\/]+\z/, 'sha256 hash format' );

        ok( $ht->matches( $pw ), 'matches() true for sha256' );

        my $ht2 = $api->htpasswd( $hash );
        ok( $ht2->matches( $pw ), 're-wrapped sha256 hash verifies' );
    };
};

subtest 'sha512 ($6$) make + matches' => sub
{

t/06.apr1.t  view on Meta::CPAN

        unless( $have_any )
        {
            skip( 'No SHA-512 crypt support and no Crypt::Passwd::XS', 1 );
        }

        my $pw = "pässwörd with ütf8"; # UTF-8 input
        my $ht = $api->htpasswd( $pw, create => 1, algo => 'sha512', sha_rounds => $sha_rounds );
        ok( $ht, 'constructed sha512 object' );

        my $hash = $ht->hash;
        like( $hash, qr/^\$6\$(?:rounds=\d+\$)?[A-Za-z0-9.\/]{1,16}\$[A-Za-z0-9.\/]+\z/, 'sha512 hash format' );

        ok( $ht->matches( $pw ), 'matches() true for sha512' );

        my $ht2 = $api->htpasswd( $hash );
        ok( $ht2->matches( $pw ), 're-wrapped sha512 hash verifies' );
    };
};

done_testing();

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

        next unless( index( $UNRESERVED, $chr ) < 0 );
        my $enc = sprintf( '%%%.2X', $ord );
        push @tests, [ $chr, $enc, sprintf( "ordinal %d", $ord ) ];
    }

    my $cnt = 0;
    foreach my $test ( @tests )
    {
        my( $expected, $encoded, $name ) = @$test;
        my $rv = $api->decode_url( $encoded ) eq $expected ? 1 : 0;
        $r->log_error( "$[class}: decode_url(): $name -> ", ( $rv ? 'ok' : 'not ok' ) ) if( $debug );
        $cnt++ if( $rv );
    }

    foreach my $test ( @tests )
    {
        my( $octets, $expected, $name ) = @$test;
        my $rv = $api->encode_url( $octets ) eq $expected ? 1 : 0;
        $r->log_error( "$[class}: encode_url(): $name -> ", ( $rv ? 'ok' : 'not ok' ) ) if( $debug );
        $cnt++ if( $rv );
    }
    return( $self->ok( $cnt == scalar( @tests ) ) );
}

my $jwt = q{eyJleHAiOjE2MzYwNzEwMzksImFsZyI6IkhTMjU2In0.eyJqdGkiOiJkMDg2Zjk0OS1mYWJmLTRiMzgtOTE1ZC1hMDJkNzM0Y2ZmNzAiLCJmaXJzdF9uYW1lIjoiSm9obiIsImlhdCI6MTYzNTk4NDYzOSwiYXpwIjoiNGQ0YWFiYWQtYmJiMy00ODgwLThlM2ItNTA0OWMwZTczNjBlIiwiaXNzIjoiaHR0cHM6Ly9hcG...
# Need to set the Authorization header in the test unit
# $r->authorization( "Bearer ${jwt}" );
sub auth { return( shift->_test({ method => 'get_auth_bearer', expect => $jwt }) ); }