File Coverage

blib/lib/Mirror/JSON.pm

Criterion	Covered	Total	%
statement	90	138	65.2
branch	14	46	30.4
condition	2	11	18.1
subroutine	25	30	83.3
pod	0	15	0.0
total	131	240	54.5

package Mirror::JSON;

use 5.005;
use strict;
use Carp              qw{ croak };
use Params::Util      qw{ _STRING _POSINT _ARRAY0 _INSTANCE };
use JSON              ();
use URI               ();
use Time::HiRes       ();
use Time::Local       ();
use LWP::Simple       ();
use Mirror::JSON::URI ();

use constant ONE_DAY     => 86700; # 1 day plus 5 minutes fudge factor
use constant TWO_DAYS    => 172800;
use constant THIRTY_DAYS => 2592000;

use vars qw{$VERSION};
BEGIN {
	$VERSION = '0.01';
}





#####################################################################
# Wrapper for the JSON::Tiny methods

sub new {
	my $class = shift;
	my $self  = bless { @_ }, $class;
	if ( _STRING($self->{uri}) ) {
		$self->{uri} = URI->new($self->{uri});
	}
	if ( _STRING($self->{timestamp}) and ! _POSINT($self->{timestamp}) ) {
		unless ( $self->{timestamp} =~ /^(\d\d\d\d)-(\d\d)-(\d\d)T(\d\d):(\d\d):(\d\d)Z$/ ) {
			return undef;
		}
		$self->{timestamp} = Time::Local::timegm( $6, $5, $4, $3, $2 - 1, $1 );
	}
	unless ( _ARRAY0($self->{mirrors}) ) {
		return undef;
	}
	foreach ( @{$self->{mirrors}} ) {
		if ( _STRING($_->{uri}) ) {
			$_->{uri} = URI->new($_->{uri});
			$_ = Mirror::JSON::URI->new( %$_ ) or return undef;
		}
	}
	return $self;
}

sub read {
	my $class = shift;
	my $file  = shift;

	# Read in the file
	local *MIRROR;
	local $/ = undef;
	open( MIRROR, $file ) or croak("open: $!");
	my $buffer = ;
	close( MIRROR ) or croak("close: $!");

	$class->read_string( $buffer );
}

sub read_string {
	my $class = shift;
	my $json  = JSON->new->decode( shift );
	$class->new( %$json );
}

sub write {
	my $self = shift;
	my $file = shift or return croak('No file name provided');

	# Write it to the file
	open( CFG, '>' . $file ) or croak("Failed to open file '$file' for writing: $!");
	print CFG $self->write_string;
	close CFG;

	return 1;
}

sub write_string {
	JSON->new->pretty->encode( $_[0]->as_scalar );
}

sub as_scalar {
	my $self = shift;
	my $hash = { %$self };
	if ( defined $hash->{source} ) {
		$hash->{source} = "$hash->{source}";
	}
	$hash;
}





#####################################################################
# Mirror::JSON Methods

sub name {
	$_[0]->{name};
}

sub uri {
	$_[0]->{uri};
}

sub timestamp {
	$_[0]->{timestamp};
}

sub age {
	$_[0]->{age} or time - $_[0]->{timestamp};
}

sub benchmark {
	$_[0]->{benchmark};
}

sub mirrors {
	@{ $_[0]->{mirrors} };
}





#####################################################################
# Main Methods

sub check_mirrors {
	my $self = shift;
	foreach my $mirror ( $self->mirrors ) {
		next if defined $mirror->{live};
		$mirror->get;
	}
	return 1;
}

# Does the mirror with the newest timestamp newer than ours
# have a different master? If so, update our master server.
# This lets us survive major reorgansations, as long as some
# of the existing mirrors are retained.
sub check_master {
	my $self = shift;

	# Make sure we have checked the mirrors
	$self->check_mirrors;

	# Anti-hijacking measure: Only do this if our current
	# age is more than 30 days. We can almost certainly
	# handle a 1 month changeover period, otherwise things
	# will only be bad for a month.
	if ( $self->age < THIRTY_DAYS ) {
		return 1;
	}

	# Find all the servers updated in the last 2 days.
	# All of them except 1 must agree (prevent hijacking,
	# and handle accidents or anti-update attack from older server)
	my %uri = ();
	map { $uri{$_->uri}++ } grep { $_->age >= 0 and $_->age < TWO_DAYS } $self->mirrors;
	my @uris = sort { $uri{$b} <=> $uri{$a} } keys %uri;
	unless ( scalar(@uris) <= 2 and $uris[0] and $uris[0] >= (scalar($self->mirrors) - 1) ) {
		# Data is weird or currupt
		return 1;
	}

	# Master has moved.
	# Pull the new master server mirror.json
	my $new_uri = Mirror::JSON::URI->new(
		uri => URI->new( $uris[0] ),
		) or return 1;
	$new_uri->get or return 1;

	# To avoid pulling a whole bunch of mirror.json files again
	# copy any mirrors from our set to the new
	my $new = $new_uri->json or return 1;
	my %old = map { $_->uri => $_ } $self->mirrors;
	foreach ( @{ $new->{mirrors} } ) {
		if ( $old{$_->uri} ) {
			$_ = $old{$_->uri};
		} else {
			$_->get;
		}
	}

	# Now overwrite ourself with the new one
	%$self = %$new;

	return 1;
}

# Select the "best" mirrors
sub select_mirrors {
	my $self   = shift;
	my $wanted = _POSINT(shift) || 3;

	# Check the mirrors
	$self->check_mirrors;

	# Start with the list of all live mirrors, and create
	# some interesting subsets.
	my @live    = sort { $a->lag <=> $b->lag     }
	              grep { $_->live                } $self->mirrors;
	my @current = grep { $_->json->age < ONE_DAY } @live;
	my @ideal   = grep { $_->lag < 2             } @current;

	# If there are enough fast and up-to-date mirrors
	# (which should be common for many people) return them.
	if ( @ideal >= $wanted ) {
		return map { $_->uri } @ideal[0 .. $wanted];
	}

	# If there are enough up-to-date mirrors
	# (which should be common) return them.
	if ( @current >= $wanted ) {
		return map { $_->uri } @current[0 .. $wanted];
	}

	# Are there ANY that are up to date
	if ( @current ) {
		return map { $_->uri } @current;
	}

	# Something is weird, just use the master site
	return ( $self->uri );
}

1;

__END__