PERL   43
checkdbl pl
Guest on 18th August 2022 01:11:24 AM


  1. #!/usr/bin/perl
  2. #
  3. # checkdbl.pl - TCP lookup table for Postfix header_checks
  4. #
  5. # This script borrows considerably from the version posted to
  6. # spam-l by joao.gouveia@anubisnetworks.com on 2010-08-31. Here,
  7. # we query multiple DBLs and use spawn(8) instead of Net::Server
  8. # for connection management. The simple goal is to query multiple
  9. # DBLs for domain names that appear in email headers.
  10. #
  11. # Thanks to Noel Jones and Stan Hoeppner for suggestions and
  12. # critique.
  13. #
  14. # To integrate in $config_directory/master.cf:
  15. #
  16. #  127.0.0.1:2526 inet  n       n       n       -       0      spawn
  17. #    user=nobody argv=/path/to/checkdbl.pl
  18. #
  19. # And in $config_directory/main.cf:
  20. #
  21. #  header_checks = tcp:[127.0.0.1]:2526
  22. #  127.0.0.1:2526_time_limit = 3600s
  23. #
  24. # UPDATED: 2010-10-26
  25.  
  26. use Net::DNS;
  27. use strict;
  28. use warnings;
  29.  
  30. #
  31. # Define the headers and DBL zones we care about.
  32. #
  33. our @headers = qw(from message-id reply-to);
  34. our @zones   = qw(dbl.spamhaus.org multi.surbl.org black.uribl.com);
  35.  
  36. #
  37. # Create our resolver object.
  38. #
  39. our $dns = Net::DNS::Resolver->new(
  40.         udp_timeout  => 2,
  41.         retry        => 2,
  42. );
  43.  
  44. #
  45. # Extract what appears to the right of '@', and verify that
  46. # it is not an IP address; then, query DBLs and return as  
  47. # soon as we get a hit. Do not check additional DBLs once
  48. # a query succeeds.
  49. #
  50. sub querybl {
  51.         return unless /\@([\w.-]+\.[[:alpha:]]+)/;
  52.         my $domain = $1;
  53.         foreach my $zone (@zones) {
  54.                 my $query = $dns->query($domain . "." . ${zone}, "A");
  55.                 if ($query) {
  56.                         foreach my $rr ($query->answer) {
  57.                                 if ($rr->address=~/^127/) {
  58.                                         return ($domain, $zone);
  59.                                 }
  60.                         }
  61.                 }
  62.         }
  63.         return;
  64. }
  65.  
  66. #
  67. # Autoflush standard output.
  68. #
  69. select STDOUT; $|++;
  70.  
  71. #
  72. # Process the headers as Postfix passes them our way,
  73. # one line at a time. For now, also process domain
  74. # names found in Resent-X headers, when X is defined
  75. # in @headers.
  76. #
  77. while (<>) {
  78.         chomp;
  79.         if (/^get\s+(?:resent-)?([\w-]+)\s*:\s*(.+)$/i) {
  80.                 my ($hdr, $data) = ($1, $2);
  81.                 unless(grep(/^$hdr/i, @headers)) {
  82.                         print "200 DUNNO\n";
  83.                         next;
  84.                 }
  85.                 my @res = querybl($data);
  86.                 if (@res) {
  87.                         print "200 REJECT $res[0], which appears in the '$hdr' header, is listed on $res[1]\n";
  88.                         next;
  89.                 }
  90.         }
  91.         print "200 DUNNO\n";
  92. }
Raw Paste

Login or Register to edit or fork this paste. It's free.