#!/usr/bin/perl
#
# $Id: PhishBL.pm 3600 2006-07-27 13:17:41Z kankri $

use strict;
use warnings;

package FS::PhishBL;

use Carp;

=head1 NAME

FS::PhishBL - FS::PhishBL API to detect phishing URLs

=head1 SYNOPSIS

use FS::PhishBL;

=cut

use Crypt::RC4;
use Digest::MD5 qw(md5);
use Fcntl qw(:flock);
use Time::HiRes qw/time/;

use FS::PhishBL::Lookup;
use FS::PhishBL::ParseURL qw(parse_ip_address url_to_blocklist_hostname);

use FS::Logger;
our $FS_Logger_facility = "phishbl";

use vars qw($VERSION);

$VERSION = qw/$Revision: 3600 $/[1];

=item new ( CONFIGHASHREF )

Construct FS::PhishBL object

=cut

sub new {
	my $class = @_ ? shift : 'FS::PhishBL';
	croak "Usage: new $class ( CONFIGHASHREF )\n"
	    unless @_ == 1;

	my ($config) = @_;

	debug(">>FS::PhishBL::new()");
	my $self = {};

	$self->{lookup} = new FS::PhishBL::Lookup($config);

	bless $self, $class;

	$self->refresh_settings($config);

	debug("<<FS::PhishBL::new()");
	return $self;
}

=item refresh_settings ( CONFIGHASHREF )

Refresh FS::PhishBL object after config settings have been changed

=cut

sub refresh_settings {
	my ($self, $config) = @_;

	debug(">>refresh_settings()");

	$self->{config} = $config;

	$self->{lookup}->refresh_settings($config);

	debug("<<refresh_settings()");
}

=item is_phish( URL )

Return classification hash for the URL. Keys are the classification
classes and items are scores. If there is no information for the URL,
an empty hash reference is returned.

Fails with die(), if there is a problem contacting the lookup server.
Catch with eval{} if needed.

=cut

sub is_phish {
	my ($self, $url) = @_;

	my $hostname = FS::PhishBL::ParseURL::url_to_blocklist_hostname($url);

	unless ($hostname) {
		debug("Bad URL in is_phish() - $url");
		return {};
	}

	my %classification = ();
	my $patterns = $self->get_patterns($hostname);
	foreach my $pat (@$patterns) {
		if ($url =~ $pat->{regex}) {
			while (my ($k, $v) = each %{$pat->{classes}}) {
				# store only if this is higer score than
				# existing one for this class, or
				# if this is zero (=clean)
				my $current = $classification{$k} || 0; 
				$classification{$k} = $v if
					!exists $classification{$k} ||
					($v > $current && $current != 0) ||
					$v == 0;
			}
		}
	}

	return \%classification;
}

=item get_patterns ( hostname )

Retrieves a list of patterns for the specified hostname.

Returns a reference to a list containing the patterns.

=cut

sub get_patterns {
	my ($self, $hostname) = @_;

	my $RANDOM_SALT_LENGTH = 8; # constant

	my @components = split /\./, $hostname;
	for (my $pos = 0; $pos < $#components; $pos++) {
		# get slice of hostname from current position to the end
		my $hostname_slice = join ('.', @components[$pos..$#components]);
		# are there patterns in the database for this hostname?
		my $data = $self->{lookup}->query($hostname_slice);

		next unless @$data > 0;

		return $data;

	}

	return [];
}

1;

=head1 AUTHOR

Dan Gardner <dan@netcraft.com>

=head1 COPYRIGHT

Copyright (C) 2005 Netcraft Ltd, all rights reserved

=cut
