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 >
Text File  |  2006-11-29  |  3KB  |  162 lines
  1. #!/usr/bin/perl
  2. #
  3. # $Id: PhishBL.pm 3600 2006-07-27 13:17:41Z kankri $
  4.  
  5. use strict;
  6. use warnings;
  7.  
  8. package FS::PhishBL;
  9.  
  10. use Carp;
  11.  
  12. =head1 NAME
  13.  
  14. FS::PhishBL - FS::PhishBL API to detect phishing URLs
  15.  
  16. =head1 SYNOPSIS
  17.  
  18. use FS::PhishBL;
  19.  
  20. =cut
  21.  
  22. use Crypt::RC4;
  23. use Digest::MD5 qw(md5);
  24. use Fcntl qw(:flock);
  25. use Time::HiRes qw/time/;
  26.  
  27. use FS::PhishBL::Lookup;
  28. use FS::PhishBL::ParseURL qw(parse_ip_address url_to_blocklist_hostname);
  29.  
  30. use FS::Logger;
  31. our $FS_Logger_facility = "phishbl";
  32.  
  33. use vars qw($VERSION);
  34.  
  35. $VERSION = qw/$Revision: 3600 $/[1];
  36.  
  37. =item new ( CONFIGHASHREF )
  38.  
  39. Construct FS::PhishBL object
  40.  
  41. =cut
  42.  
  43. sub new {
  44.     my $class = @_ ? shift : 'FS::PhishBL';
  45.     croak "Usage: new $class ( CONFIGHASHREF )\n"
  46.         unless @_ == 1;
  47.  
  48.     my ($config) = @_;
  49.  
  50.     debug(">>FS::PhishBL::new()");
  51.     my $self = {};
  52.  
  53.     $self->{lookup} = new FS::PhishBL::Lookup($config);
  54.  
  55.     bless $self, $class;
  56.  
  57.     $self->refresh_settings($config);
  58.  
  59.     debug("<<FS::PhishBL::new()");
  60.     return $self;
  61. }
  62.  
  63. =item refresh_settings ( CONFIGHASHREF )
  64.  
  65. Refresh FS::PhishBL object after config settings have been changed
  66.  
  67. =cut
  68.  
  69. sub refresh_settings {
  70.     my ($self, $config) = @_;
  71.  
  72.     debug(">>refresh_settings()");
  73.  
  74.     $self->{config} = $config;
  75.  
  76.     $self->{lookup}->refresh_settings($config);
  77.  
  78.     debug("<<refresh_settings()");
  79. }
  80.  
  81. =item is_phish( URL )
  82.  
  83. Return classification hash for the URL. Keys are the classification
  84. classes and items are scores. If there is no information for the URL,
  85. an empty hash reference is returned.
  86.  
  87. Fails with die(), if there is a problem contacting the lookup server.
  88. Catch with eval{} if needed.
  89.  
  90. =cut
  91.  
  92. sub is_phish {
  93.     my ($self, $url) = @_;
  94.  
  95.     my $hostname = FS::PhishBL::ParseURL::url_to_blocklist_hostname($url);
  96.  
  97.     unless ($hostname) {
  98.         debug("Bad URL in is_phish() - $url");
  99.         return {};
  100.     }
  101.  
  102.     my %classification = ();
  103.     my $patterns = $self->get_patterns($hostname);
  104.     foreach my $pat (@$patterns) {
  105.         if ($url =~ $pat->{regex}) {
  106.             while (my ($k, $v) = each %{$pat->{classes}}) {
  107.                 # store only if this is higer score than
  108.                 # existing one for this class, or
  109.                 # if this is zero (=clean)
  110.                 my $current = $classification{$k} || 0; 
  111.                 $classification{$k} = $v if
  112.                     !exists $classification{$k} ||
  113.                     ($v > $current && $current != 0) ||
  114.                     $v == 0;
  115.             }
  116.         }
  117.     }
  118.  
  119.     return \%classification;
  120. }
  121.  
  122. =item get_patterns ( hostname )
  123.  
  124. Retrieves a list of patterns for the specified hostname.
  125.  
  126. Returns a reference to a list containing the patterns.
  127.  
  128. =cut
  129.  
  130. sub get_patterns {
  131.     my ($self, $hostname) = @_;
  132.  
  133.     my $RANDOM_SALT_LENGTH = 8; # constant
  134.  
  135.     my @components = split /\./, $hostname;
  136.     for (my $pos = 0; $pos < $#components; $pos++) {
  137.         # get slice of hostname from current position to the end
  138.         my $hostname_slice = join ('.', @components[$pos..$#components]);
  139.         # are there patterns in the database for this hostname?
  140.         my $data = $self->{lookup}->query($hostname_slice);
  141.  
  142.         next unless @$data > 0;
  143.  
  144.         return $data;
  145.  
  146.     }
  147.  
  148.     return [];
  149. }
  150.  
  151. 1;
  152.  
  153. =head1 AUTHOR
  154.  
  155. Dan Gardner <dan@netcraft.com>
  156.  
  157. =head1 COPYRIGHT
  158.  
  159. Copyright (C) 2005 Netcraft Ltd, all rights reserved
  160.  
  161. =cut
  162.