view release on metacpan or  search on metacpan

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

package Apache2::FileHash;

use strict;
use warnings;

our $VERSION = '0.01';

use Carp;
use Digest::MD5;
use Math::BigInt;
use File::Temp;
use File::Copy;
use YAML::Tiny;
use File::Basename;

use Apache2::RequestRec ();
use Apache2::Const -compile => qw(DECLINED OK REDIRECT);

our $ConfigFile = "FileHash.yml";
our $Config;

sub hashing_function
{
    my ($r, $path) = @_;

    my $hex = &Digest::MD5::md5_hex($path);
    my $filename = "0x$hex";

    my (undef, undef, $suffix) = &File::Basename::fileparse($path, qr/\.(.*?)$/);

    $filename .= $suffix;

    return($filename);
}

sub file_exists
{
    my ($r, $headers) = @_;

    my $filename = &hashing_function($r, $headers);

    if (-e "/$$Config[0]{GLOBALS}{base_dir}/$filename") {
        return(Apache2::Const::DECLINED);
    }
    else {
        return(Apache2::Const::OK);
    }
}

sub netloc
{
    my ($r, $filename) = @_;

    my (undef, undef, $suffix) = &File::Basename::fileparse($filename, qr/\.(.*?)$/);

    my ($package) = (caller(0))[0];
    $package =~ s#^.*:##;

    my $orig_filename = $filename;
    $filename =~ s/$suffix$//;

    my $num = Math::BigInt->new($filename);
    my $num_buckets = scalar(@{ $Config->[0]{BUCKETS} });
    my $bucket_index = $num % $num_buckets;
    my $bucket = $Config->[0]{BUCKETS}[$bucket_index];

    my ($location, $name, $method, $port);

    $location = $Config->[0]{METHOD}{$package}{root_uri};
    $name = $bucket->{name};
    $method = $bucket->{method};
    $port = $bucket->{port};

    # warn("${method}://${name}:$port/$location/$orig_filename");
    return("${method}://${name}:$port/$location/$orig_filename");
}

sub getbucket
{
    my ($r, $filename) = @_;

    my (undef, undef, $suffix) = &File::Basename::fileparse($filename, qr/\.(.*?)$/);

    my $orig_filename = $filename;
    $filename =~ s/$suffix$//;

    my $num = Math::BigInt->new($filename);
    my $num_buckets = scalar(@{ $Config->[0]{BUCKETS} });
    my $bucket_index = $num % $num_buckets;
    my $bucket = $Config->[0]{BUCKETS}[$bucket_index];

    return($bucket);
}

sub inbucket
{
    my ($r, $path) = @_;

    my $uri = $r->uri();
    my $server_name = $r->get_server_name();
    my $port = $r->get_server_port();
    my $cur_netloc = "http://$server_name:$port/$uri"; # ugh.. hardcoded

    my $filename = &hashing_function($r, $path);
    # my $new_netloc = &netloc($r, $filename);

    my $bucket = &getbucket($r, $filename);

    my $location = $bucket->{location};
    my $name = $bucket->{name};
    my $method = $bucket->{method};
    $port = $bucket->{port};

    my $new_netloc = "${method}://${name}:$port/$uri";

    # warn(qq(return($cur_netloc eq $new_netloc)));