home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ftp.f-secure.com
/
2014.06.ftp.f-secure.com.tar
/
ftp.f-secure.com
/
support
/
hotfix
/
fsis
/
IS-SpamControl.fsfix
/
iufssc
/
lib
/
FS
/
PhishBL.pm
< prev
next >
Wrap
Text File
|
2006-11-29
|
3KB
|
162 lines
#!/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