modules/exim/files/common/exim_surbl.pl

   1 #
   2 # Copyright (c) 2006-2007 Erik Mugele.  All rights reserved.
   3 #
   4 # Redistribution and use in source and binary forms, with or without
   5 # modification, are permitted provided that the following conditions
   6 # are met:
   7 # 1. Redistributions of source code must retain the above copyright
   8 #    notice, this list of conditions and the following disclaimer.
   9 # 2. Redistributions in binary form must reproduce the above copyright
  10 #    notice, this list of conditions and the following disclaimer in the
  11 #    documentation and/or other materials provided with the distribution.
  12 #
  13 # THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
  14 # IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
  15 # OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
  16 # IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
  17 # INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
  18 # NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
  19 # DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
  20 # THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
  21 # (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
  22 # THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  23 #
  24 # NOTES
  25 # -----
  26 #
  27 # 1. This script makes use of the Country Code Top Level
  28 # Domains (ccTLD) provided by the SURBL group at
  29 # http://spamcheck.freeapp.net/two-level-tlds
  30 # THE VARIABLE $cctld_file MUST BE SET TO THE FULL PATH AND
  31 # NAME OF THE FILE CONTAINING THE CCTLD LIST!  (see below)
  32 #
  33 # 2. This script makes use of whitelisting of popular domains.  The
  34 # source of the list can be found here:
  35 # http://spamassassin.apache.org/full/3.1.x/dist/rules/25_uribl.cf
  36 # These are domains that are whitelisted by the SURBL group so it
  37 # doesn't make sense to waste resources doing lookups on them.
  38 # THE VARIABLE $whitelist_file MUST BE SET TO THE FULL PATH AND
  39 # NAME OF THE FILE CONTAINING THE WHITE LIST!  (see below)
  40 #
  41 # 3. Per the guidelines at http://www.surbl.org, if your site processes
  42 # more than 100,000 messages per day, you should NOT be using the
  43 # public SURBL name servers but should be rsync-ing from them and
  44 # running your own.  See http://www3.surbl.org/rsync-signup.html
  45 #
  46 sub surblspamcheck
  47 {
  48 # Designed and written by Erik Mugele, 2004-2006
  49 # http://www.teuton.org/~ejm
  50 # Version 2.0
  51
  52     # The following variable is the full path to the file containing the
  53     # list of Country Code Top Level Domains (ccTLD).
  54     # ---------------------------------------------------------------------
  55     # THIS VARIABLE MUST BE SET TO THE FULL PATH AND NAME OF THE FILE
  56     # CONTAINING THE CCTLD LIST!
  57     # ---------------------------------------------------------------------
  58     my $cctld_file = "/etc/exim4/ccTLD.txt";
  59
  60     # The following variable is the full path to the file containing
  61     # whitelist entries.
  62     # ---------------------------------------------------------------------
  63     # THIS VARIABLE MUST BE SET TO THE FULL PATH AND NAME OF THE FILE
  64     # CONTAINING THE WHITELIST DOMAINS!
  65     # ---------------------------------------------------------------------
  66     my $whitelist_file = "/etc/exim4/surbl_whitelist.txt";
  67
  68     # This variable defines the maximum MIME file size that will be checked
  69     # if this script is called by the MIME ACL.  This is primarily to
  70     # keep the load down on the server.  Size is in bytes.
  71     my $max_file_size = 50000;
  72
  73     # The following two variables enable or disable the SURBL and URIBL
  74     # lookups.  Set to 1 to enable and 0 to disable.
  75     my $surbl_enable = 1;
  76     my $uribl_enable = 1;
  77
  78     # Check to see if a decode MIME attachment is being checked or
  79     # just a plain old text message with no attachments
  80     my $exim_body = "";
  81     my $mime_filename = Exim::expand_string('$mime_decoded_filename');
  82     if ($mime_filename) {
  83         # DEBUG Statement
  84         #warn ("MIME FILENAME: $mime_filename\n");
  85         # If the MIME file is too large, skip it.
  86         if (-s $mime_filename <= $max_file_size) {
  87             open(fh,"<$mime_filename");
  88             binmode(fh);
  89             while (read(fh,$buff,1024)) {
  90                 $exim_body .= $buff;
  91             }
  92             close (fh);
  93         } else {
  94             $exim_body = "";
  95         }
  96     } else {
  97         $exim_body = Exim::expand_string('$message_body');
  98     }
  99
 100     sub surbllookup {
 101         # This subroutine does the actual DNS lookup and builds and returns
 102         # the return message for the SURBL lookup.
 103         my @params = @_;
 104         my $surbldomain = ".multi.surbl.org";
 105         @dnsbladdr=gethostbyname($params[0].$surbldomain);
 106         # If gethostbyname() returned anything, build a return message.
 107         $return_string = "";
 108         if (scalar(@dnsbladdr) != 0) {
 109             $return_string = "Blacklisted URL in message. (".$params[0].") in";
 110             @surblipaddr = unpack('C4',($dnsbladdr[4])[0]);
 111             if ($surblipaddr[3] & 64) {
 112                 $return_string .= " [jp]";
 113             }
 114             if ($surblipaddr[3] & 32) {
 115                 $return_string .= " [ab]";
 116             }
 117             if ($surblipaddr[3] & 16) {
 118                 $return_string .= " [ob]";
 119             }
 120             if ($surblipaddr[3] & 8) {
 121                 $return_string .= " [ph]";
 122             }
 123             if ($surblipaddr[3] & 4) {
 124                 $return_string .= " [ws]";
 125             }
 126             if ($surblipaddr[3] & 2) {
 127                 $return_string .= " [sc]";
 128             }
 129             $return_string .= ". See http://www.surbl.org/lists.html.";
 130         }
 131         return $return_string;
 132     }
 133
 134     sub uribllookup {
 135         # This subroutine does the actual DNS lookup and builds and returns
 136         # the return message for the URIBL check.
 137         my @params = @_;
 138         my $surbldomain = ".black.uribl.com";
 139         @dnsbladdr=gethostbyname($params[0].$surbldomain);
 140         # If gethostbyname() returned anything, build a return message.
 141         $return_string = "";
 142         if (scalar(@dnsbladdr) != 0) {
 143             $return_string = "Blacklisted URL in message. (".$params[0].") in";
 144             @surblipaddr = unpack('C4',($dnsbladdr[4])[0]);
 145             if ($surblipaddr[3] & 8) {
 146                 $return_string .= " [red]";
 147             }
 148             if ($surblipaddr[3] & 4) {
 149                 $return_string .= " [grey]";
 150             }
 151             if ($surblipaddr[3] & 2) {
 152                 $return_string .= " [black]";
 153             }
 154             $return_string .= ". See http://lookup.uribl.com.";
 155         }
 156         return $return_string;
 157     }
 158
 159     sub converthex {
 160         # This subroutin converts two hex characters to an ASCII character.
 161         # It is called when ASCII obfuscation or Printed-Quatable characters
 162         # are found (i.e. %AE or =AE).
 163         # It should return a converted/plain address after splitting off
 164         # everything that isn't part of the address portion of the URL.
 165         my @ob_parts = @_;
 166         my $address = $ob_parts[0];
 167         for (my $j=1; $j < scalar(@ob_parts); $j++) {
 168             $address .= chr(hex(substr($ob_parts[$j],0,2)));
 169             $address .= substr($ob_parts[$j],2,);
 170         }
 171         $address = (split(/[^A-Za-z0-9._\-]/,$address))[0];
 172         return $address
 173     }
 174
 175     ################
 176     # Main Program #
 177     ################
 178
 179     if ($exim_body) {
 180         # Find all the URLs in the message by finding the HTTP string
 181         @parts = split /[hH][tT][tT][pP]:\/\//,$exim_body;
 182         if (scalar(@parts) > 1) {
 183             # Read the entries from the ccTLD file.
 184             open (cctld_handle,$cctld_file) or die "Can't open $cctld_file.\n";
 185             while (<cctld_handle>) {
 186                 next if (/^#/ || /^$/ || /^\s$/);
 187                 push(@cctlds,$_);
 188             }
 189             close (cctld_handle) or die "Close: $!\n";
 190             # Read the entries from the whitelist file.
 191             open (whitelist_handle,$whitelist_file) or die "Can't open $whitelist_file.\n";
 192             while (<whitelist_handle>) {
 193                 next if (/^#/ || /^$/ || /^\s$/);
 194                 push(@whitelist,$_);
 195             }
 196             close (whitelist_handle) or die "Close: $!\n";
 197             # Go through each of the HTTP parts that were found in the message
 198             for ($i=1; $i < scalar(@parts); $i++) {
 199                 # Special case of Quoted Printable EOL marker
 200                 $parts[$i] =~ s/=\n//g;
 201                     # Split the parts and find the address portion of the URL.
 202                 # Address SHOULD be either a FQDN, IP address, or encoded address.
 203                 $address = (split(/[^A-Za-z0-9\._\-%=]/,$parts[$i]))[0];
 204                 # Check for an =.  If it exists, we assume the URL is doing
 205                 # Quoted-Printable.  Decode it and redine $address
 206                 if ($address =~ /=/) {
 207                     @ob_parts = split /=/,$address;
 208                     $address = converthex(@ob_parts);
 209                 }
 210                 # Check for a %.  If it exists the URL is using % ASCII
 211                 # obfuscation.  Decode it and redefine $address.
 212                 if ($address =~ /%/) {
 213                     @ob_parts = split /%/,$address;
 214                     $address = converthex(@ob_parts);
 215                 }
 216                 # Split the the address into the elements separated by periods.
 217                 @domain = split /\./,$address;
 218                 # Check the length of the domain name.  If less then two elements
 219                 # at this point it is probably bogus or there is a bug in one of
 220                 # the decoding/converting routines above.
 221                 if (scalar(@domain) >= 2) {
 222                     $return_result="";
 223                     # By default, assume that the domain check is on a
 224                     # "standard" two level domain
 225                     $spamcheckdomain=$domain[-2].".".$domain[-1];
 226                     # Check for a two level domain
 227                     if (((scalar(@domain) == 2) || (scalar(@domain) >= 5))  &&
 228                         (grep(/^$spamcheckdomain$/i,@cctlds))) {
 229                         $return_result="cctld";
 230                     }
 231                     # Check for a three level domain
 232                     if (scalar(@domain) == 3) {
 233                         if (grep(/^$spamcheckdomain$/i,@cctlds)) {
 234                             $spamcheckdomain=$domain[-3].".".$spamcheckdomain;
 235                             if (grep(/^$spamcheckdomain$/,@cctlds)) {
 236                                 $return_result="cctld";
 237                             }
 238                         }
 239                     }
 240                     # Check for a four level domain
 241                     if (scalar(@domain) == 4) {
 242                         # Check to see if the domain is an IP address
 243                         if ($domain[-1] =~ /[a-zA-Z]/) {
 244                             if (grep(/^$spamcheckdomain$/i,@cctlds)) {
 245                                 $spamcheckdomain=$domain[-3].".".$spamcheckdomain;
 246                                 if (grep(/^$spamcheckdomain$/i,@cctlds)) {
 247                                     $spamcheckdomain=$domain[-4].".".$spamcheckdomain;
 248                                 }
 249                             }
 250                         } else {
 251                             # Domain is an IP address
 252                             $spamcheckdomain=$domain[3].".".$domain[2].
 253                                 ".".$domain[1].".".$domain[0];
 254                         }
 255                     }
 256                     # DEBUG statement
 257                     #warn ("FOUND DOMAIN ($mime_filename): $spamcheckdomain\n");
 258                     # If whitelisting is enabled check domain against the
 259                     # whitelist.
 260                     if ($whitelist_file ne "") {
 261                         foreach $whitelist_entry (@whitelist) {
 262                             chomp($whitelist_entry);
 263                             if ($spamcheckdomain =~ m/^$whitelist_entry$/i) {
 264                                 $return_result="whitelisted";
 265                                 last;
 266                             }
 267                         }
 268                     }
 269                     # If the domain is whitelisted or in the cctld skip adding
 270                     # it to the lookup list.
 271                     if ($return_result eq "") {
 272                         if (scalar(@lookupdomains) > 0) {
 273                             # Check so see if the domain already is in the list.
 274                             if (not grep(/^$spamcheckdomain$/i,@lookupdomains)) {
 275                                     push(@lookupdomains,$spamcheckdomain);
 276                             }
 277                         } else {
 278                             push(@lookupdomains,$spamcheckdomain);
 279                         }
 280                     }
 281                 }
 282             }
 283             # If there are items in the lookupdomains list then
 284             # perform lookups on them.  If there are not, something is wrong
 285             # and just return false.  There should always be something in the list.
 286             if (scalar(@lookupdomains) > 0) {
 287                 foreach $i (@lookupdomains) {
 288                     # DEBUG statement.
 289                     #warn ("CHECKING DOMAIN ($mime_filename): $i\n");
 290                     # If SURBL lookups are enabled do an SURBL lookup
 291                     if ($surbl_enable == 1) {
 292                         $return_result = surbllookup($i);
 293                     }
 294                     # If URIBL lookups are enabled and the SURBL lookup failed
 295                     # do a URIBL lookup
 296                     if (($uribl_enable == 1) && ($return_result eq "")) {
 297                         $return_result = uribllookup($i);
 298                     }
 299                     # If we got a hit return the result to Exim
 300                     if ($return_result ne "") {
 301                         undef @cctlds;
 302                         undef @whitelist;
 303                         return $return_result;
 304                     }
 305                 }
 306             }
 307         }
 308     }
 309     # We didn't find any URLs or the URLs we did find were not
 310     # listed so return false.
 311     undef @cctlds;
 312     undef @whitelist;
 313     return false;
 314 }
 315